summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
authorJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
committerJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
commita8435165b84c32fd2ebdd1281dd6ee077e07ad5a (patch)
tree791936d014aeaa26174c2dcbef34c14f3329dd04 /compiler/parser
parent7805441b4d5e22eb63a501e1e40383d10380dc92 (diff)
parentf03a41d4bf9418ee028ecb51654c928b2da74edd (diff)
downloadhaskell-wip/binary-readerT.tar.gz
Merge branch 'master' into wip/binary-readerTwip/binary-readerT
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/ApiAnnotation.hs4
-rw-r--r--compiler/parser/Lexer.x253
-rw-r--r--compiler/parser/Parser.y557
-rw-r--r--compiler/parser/RdrHsSyn.hs916
4 files changed, 812 insertions, 918 deletions
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..fc6779a359 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 accommodate 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..0076a01992 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
@@ -764,7 +760,7 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located (HsModule GhcPs) }
: maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
@@ -772,13 +768,13 @@ signature :: { Located (HsModule GhcPs) }
module :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7)
+ ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
(snd $ snd $7) $4 $1)
)
([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
| body2
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule Nothing Nothing
+ ams (L loc (HsModule Nothing Nothing
(fst $ snd $1) (snd $ snd $1) Nothing Nothing))
(fst $1) }
@@ -829,15 +825,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located (HsModule GhcPs) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
)) [mj AnnModule $2,mj AnnWhere $6] }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (cL loc (HsModule Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -909,7 +905,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }
qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of
- l@(dL->L _ ImpExpQcWildcard) ->
+ l@(L _ ImpExpQcWildcard) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,(snd (unLoc $3) : snd $1))
l -> (ams (head (snd $1)) [mj AnnComma $2] >>
@@ -971,7 +967,7 @@ importdecl :: { LImportDecl GhcPs }
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec
{% do {
; checkImportDecl $4 $7
- ; ams (cL (comb4 $1 $6 (snd $8) $9) $
+ ; ams (L (comb4 $1 $6 (snd $8) $9) $
ImportDecl { ideclExt = noExtField
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
@@ -1018,7 +1014,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
- return (cL (gl $1) (Just (b, checkedIe))) }
+ return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE GhcPs]) }
@@ -1167,7 +1163,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
+ ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1254,24 +1250,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) }
ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
: '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3]
,Just (unLoc $2)) }
- | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in
- cL loc ([],Just (unLoc $2)) }
+ | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in
+ L loc ([],Just (unLoc $2)) }
| '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
,mcc $3],Nothing) }
- | vocurly '..' close { let (dL->L loc _) = $2 in
- cL loc ([mj AnnDotdot $2],Nothing) }
+ | vocurly '..' close { let (L loc _) = $2 in
+ L loc ([mj AnnDotdot $2],Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let (dL->L loc (anns, eqn)) = $3 in
- asl (unLoc $1) $2 (cL loc eqn)
+ {% let (L loc (anns, eqn)) = $3 in
+ asl (unLoc $1) $2 (L loc eqn)
>> ams $3 anns
- >> return (sLL $1 $> (cL loc eqn : unLoc $1)) }
+ >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
- | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in
+ | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in
ams $1 anns
- >> return (sLL $1 $> [cL loc eqn]) }
+ >> return (sLL $1 $> [L loc eqn]) }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
@@ -1508,7 +1504,7 @@ where_decls :: { Located ([AddAnn]
, Located (OrdList (LHsDecl GhcPs))) }
: 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2
:mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
- | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+ | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig GhcPs }
@@ -1592,7 +1588,7 @@ decllist_inst
:: { Located ([AddAnn]
, OrdList (LHsDecl GhcPs)) } -- Reversed
: '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
- | vocurly decls_inst close { cL (gl $2) (unLoc $2) }
+ | vocurly decls_inst close { L (gl $2) (unLoc $2) }
-- Instance body
--
@@ -1628,7 +1624,7 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }
decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }
: '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
+ | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
--
@@ -1642,7 +1638,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
- | vocurly dbinds close { cL (getLoc $2) ([]
+ | vocurly dbinds close { L (getLoc $2) ([]
,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }
@@ -1670,7 +1666,7 @@ rule :: { LRuleDecl GhcPs }
{%runECP_P $4 >>= \ $4 ->
runECP_P $6 >>= \ $6 ->
ams (sLL $1 $> $ HsRule { rd_ext = noExtField
- , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1)
+ , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
, rd_lhs = $4, rd_rhs = $6 })
@@ -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]) }
@@ -1765,14 +1778,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) }
(fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located StringLiteral]) }
- : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) }
+ : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
| '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
stringlist :: { Located (OrdList (Located StringLiteral)) }
: stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> (unLoc $1 `snocOL`
- (cL (gl $3) (getStringLiteral $3)))) }
- | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) }
+ (L (gl $3) (getStringLiteral $3)))) }
+ | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
| {- empty -} { noLoc nilOL }
-----------------------------------------------------------------------------
@@ -1826,7 +1839,7 @@ safety :: { Located Safety }
fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
: STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3]
- ,(cL (getLoc $1)
+ ,(L (getLoc $1)
(getStringLiteral $1), $2, mkLHsSigType $4)) }
| var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2]
,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
@@ -1872,7 +1885,7 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
forall_vis_flag :: { (AddAnn, ForallVisFlag) }
: '.' { (mj AnnDot $1, ForallInvis) }
- | '->' { (mj AnnRarrow $1, ForallVis) }
+ | '->' { (mu AnnRarrow $1, ForallVis) }
-- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation
ktype :: { LHsType GhcPs }
@@ -1992,13 +2005,13 @@ typedoc :: { LHsType GhcPs }
[mu AnnRarrow $2] }
| btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $1 $2))
$4)
[mu AnnRarrow $3] }
| docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
>> ams (sLL $1 $> $
- HsFunTy noExtField (cL (comb2 $1 $2)
+ HsFunTy noExtField (L (comb2 $1 $2)
(HsDocTy noExtField $2 $1))
$4)
[mu AnnRarrow $3] }
@@ -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
@@ -2138,7 +2157,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] }
| fd { sL1 $1 [$1] }
fd :: { Located (FunDep (Located RdrName)) }
- : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3)
+ : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)))
[mu AnnRarrow $2] }
@@ -2181,13 +2200,13 @@ gadt_constrlist :: { Located ([AddAnn]
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1
,moc $2
,mcc $4]
, unLoc $3) }
| 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
- cL (comb2 $1 $3)
+ L (comb2 $1 $3)
([mj AnnWhere $1]
, unLoc $3) }
| {- empty -} { noLoc ([],[]) }
@@ -2195,8 +2214,8 @@ gadt_constrlist :: { Located ([AddAnn]
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr_with_doc ';' gadt_constrs
{% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) }
- | gadt_constr_with_doc { cL (gl $1) [$1] }
+ >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+ | gadt_constr_with_doc { L (gl $1) [$1] }
| {- empty -} { noLoc [] }
-- We allow the following forms:
@@ -2228,12 +2247,12 @@ with constructor names (see Note [Parsing data constructors is hard]).
Due to simplified syntax, GADT constructor names (left-hand side of '::')
use simpler grammar production than usual data constructor names. As a
-consequence, GADT constructor names are resticted (names like '(*)' are
+consequence, GADT constructor names are restricted (names like '(*)' are
allowed in usual data constructors, but not in GADTs).
-}
constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }
- : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2]
+ : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2]
,addConDocs (unLoc $3) $1)}
constrs1 :: { Located [LConDecl GhcPs] }
@@ -2297,7 +2316,7 @@ They must be kept identical except for their treatment of 'docprev'.
constr :: { LConDecl GhcPs }
: maybe_docnext forall constr_context '=>' constr_stuff
{% ams (let (con,details,doc_prev) = unLoc $5 in
- addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2)
(Just $3)
details))
@@ -2305,7 +2324,7 @@ constr :: { LConDecl GhcPs }
(mu AnnDarrow $4:(fst $ unLoc $2)) }
| maybe_docnext forall constr_stuff
{% ams ( let (con,details,doc_prev) = unLoc $3 in
- addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con
+ addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
(snd $ unLoc $2)
Nothing -- No context
details))
@@ -2333,8 +2352,8 @@ fielddecls1 :: { [LConDeclField GhcPs] }
fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
- {% ams (cL (comb2 $2 $4)
- (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
+ {% ams (L (comb2 $2 $4)
+ (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
@@ -2352,17 +2371,17 @@ derivings :: { HsDeriving GhcPs }
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2)
+ in ams (L full_loc $ HsDerivingClause noExtField Nothing $2)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3)
[mj AnnDeriving $1] }
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2)
+ in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
[mj AnnDeriving $1] }
deriv_clause_types :: { Located [LHsSigType GhcPs] }
@@ -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
@@ -2437,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs }
case r of {
(FunBind _ n _ _ _) ->
amsL l (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (dL->L lh _lhs) _rhs _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
amsL lh (fst $2) >> return () } ;
_ <- amsL l (ann ++ (fst $ unLoc $3));
return $! (sL l $ ValD noExtField r) } }
@@ -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)))) }
-----------------------------------------------------------------------------
@@ -2627,66 +2629,57 @@ exp10_top :: { ECP }
amms (mkHsNegAppPV (comb2 $1 $>) $2)
[mj AnnMinus $1] }
-
- | hpc_annot exp {% runECP_P $2 >>= \ $2 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc $1)
- (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
- (fst $ fst $ fst $ unLoc $1) }
-
- | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsCoreAnn noExtField (getCORE_PRAGs $1) (getStringLiteral $2) $4)
- [mo $1,mj AnnVal $2
- ,mc $3] }
- -- hdaume: core annotation
+ | exp_annot (prag_hpc) { $1 }
+ | exp_annot (prag_core) { $1 }
| fexp { $1 }
exp10 :: { ECP }
: exp10_top { $1 }
- | scc_annot exp {% runECP_P $2 >>= \ $2 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsSCC noExtField (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
- (fst $ fst $ unLoc $1) }
+ | exp_annot(prag_scc) { $1 }
optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
-scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }
+prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
; return $ sLL $1 $>
- (([mo $1,mj AnnValStr $2
- ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }
- | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2
- ,mc $3],getSCC_PRAGs $1)
- ,(StringLiteral NoSourceText (getVARID $2))) }
-
-hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))),
- ((SourceText,SourceText),(SourceText,SourceText))
- ) }
+ ([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 '#-}'
- { sLL $1 $> $ ((([mo $1,mj AnnVal $2
+ { let getINT = fromInteger . il_value . getINTEGER in
+ sLL $1 $> $ ([mo $1,mj AnnVal $2
,mj AnnVal $3,mj AnnColon $4
,mj AnnVal $5,mj AnnMinus $6
,mj AnnVal $7,mj AnnColon $8
,mj AnnVal $9,mc $10],
- getGENERATED_PRAGs $1)
- ,((getStringLiteral $2)
- ,( fromInteger $ il_value $ getINTEGER $3
- , fromInteger $ il_value $ getINTEGER $5
- )
- ,( fromInteger $ il_value $ getINTEGER $7
- , fromInteger $ il_value $ getINTEGER $9
- )
- ))
- , (( getINTEGERs $3
- , getINTEGERs $5
- )
- ,( getINTEGERs $7
- , getINTEGERs $9
- )))
- }
+ HsPragTick noExtField
+ (getGENERATED_PRAGs $1)
+ (getStringLiteral $2,
+ (getINT $3, getINT $5),
+ (getINT $7, getINT $9))
+ ((getINTEGERs $3, getINTEGERs $5),
+ (getINTEGERs $7, getINTEGERs $9) )) }
+
+prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
+ : '{-# 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 $
@@ -2694,11 +2687,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 +2702,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 $
@@ -2764,7 +2764,7 @@ aexp :: { ECP }
(mj AnnDo $1:(fst $ unLoc $2)) }
| 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecpFromExp $
- ams (cL (comb2 $1 $2)
+ ams (L (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
@@ -2812,7 +2812,7 @@ aexp2 :: { ECP }
| '(#' texp '#)' { ECP $
runECP_PV $2 >>= \ $2 ->
- amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)]))
+ amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' { ECP $
$2 >>= \ $2 ->
@@ -2863,22 +2863,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 }
@@ -2951,7 +2946,7 @@ tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }
{ $2 >>= \ $2 ->
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
; return
- ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } }
+ ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }
| bars texp bars0
{ runECP_PV $2 >>= \ $2 -> return $
@@ -2964,16 +2959,16 @@ commas_tup_tail : commas tup_tail
do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
; return (
(head $ fst $1
- ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } }
+ ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } }
-- Always follows a comma
tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
: texp commas_tup_tail { runECP_PV $1 >>= \ $1 ->
$2 >>= \ $2 ->
addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((cL (gl $1) (Just $1)) : snd $2) }
+ return ((L (gl $1) (Just $1)) : snd $2) }
| texp { runECP_PV $1 >>= \ $1 ->
- return [cL (gl $1) (Just $1)] }
+ return [L (gl $1) (Just $1)] }
| {- empty -} { return [noLoc Nothing] }
-----------------------------------------------------------------------------
@@ -2988,32 +2983,32 @@ list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) }
| lexps { \loc -> $1 >>= \ $1 ->
mkHsExplicitListPV loc (reverse $1) }
| texp '..' { \loc -> runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ ArithSeq noExtField Nothing (From $1))
+ ams (L loc $ ArithSeq noExtField Nothing (From $1))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
+ ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
[mj AnnDotdot $2]
>>= ecpFromExp' }
| texp ',' exp '..' exp { \loc ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
runECP_PV $5 >>= \ $5 ->
- ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
+ ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
[mj AnnComma $2,mj AnnDotdot $4]
>>= ecpFromExp' }
| texp '|' flattenedpquals
{ \loc ->
checkMonadComp >>= \ ctxt ->
runECP_PV $1 >>= \ $1 ->
- ams (cL loc $ mkHsComp ctxt (unLoc $3) $1)
+ ams (L loc $ mkHsComp ctxt (unLoc $3) $1)
[mj AnnVbar $2]
>>= ecpFromExp' }
@@ -3048,7 +3043,7 @@ pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }
: squals '|' pquals
{% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
- | squals { cL (getLoc $1) [reverse (unLoc $1)] }
+ | squals { L (getLoc $1) [reverse (unLoc $1)] }
squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last
-- one can "grab" the earlier ones
@@ -3061,7 +3056,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
- return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
+ return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
| qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
@@ -3100,7 +3095,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
-- Guards
guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
+ : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
@@ -3118,7 +3113,7 @@ altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Loca
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse (snd $ unLoc $2))) }
| vocurly alts close { $2 >>= \ $2 -> return $
- cL (getLoc $2) (fst $ unLoc $2
+ L (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
| '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) }
| vocurly close { return $ noLoc ([],[]) }
@@ -3194,24 +3189,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 }
@@ -3225,7 +3210,7 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat
sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
| vocurly stmts close { $2 >>= \ $2 -> return $
- cL (gl $2) (fst $ unLoc $2
+ L (gl $2) (fst $ unLoc $2
,reverse $ snd $ unLoc $2) }
-- do { ;; s ; s ; ; s ;; }
@@ -3473,7 +3458,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 +3503,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 +3520,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 +3582,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 +3658,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))) }
-----------------------------------------------------------------------------
@@ -3785,89 +3765,87 @@ maybe_docnext :: { Maybe LHsDocString }
happyError :: P a
happyError = srcParseFail
-getVARID (dL->L _ (ITvarid x)) = x
-getCONID (dL->L _ (ITconid x)) = x
-getVARSYM (dL->L _ (ITvarsym x)) = x
-getCONSYM (dL->L _ (ITconsym x)) = x
-getQVARID (dL->L _ (ITqvarid x)) = x
-getQCONID (dL->L _ (ITqconid x)) = x
-getQVARSYM (dL->L _ (ITqvarsym x)) = x
-getQCONSYM (dL->L _ (ITqconsym x)) = x
-getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x
-getLABELVARID (dL->L _ (ITlabelvarid x)) = x
-getCHAR (dL->L _ (ITchar _ x)) = x
-getSTRING (dL->L _ (ITstring _ x)) = x
-getINTEGER (dL->L _ (ITinteger x)) = x
-getRATIONAL (dL->L _ (ITrational x)) = x
-getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x
-getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x
-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)
-getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x
-
-getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x
-getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x
-getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x
-getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x)
-
-getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src
-getCHARs (dL->L _ (ITchar src _)) = src
-getSTRINGs (dL->L _ (ITstring src _)) = src
-getPRIMCHARs (dL->L _ (ITprimchar src _)) = src
-getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src
-getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src
-getPRIMWORDs (dL->L _ (ITprimword src _)) = src
+getVARID (L _ (ITvarid x)) = x
+getCONID (L _ (ITconid x)) = x
+getVARSYM (L _ (ITvarsym x)) = x
+getCONSYM (L _ (ITconsym x)) = x
+getQVARID (L _ (ITqvarid x)) = x
+getQCONID (L _ (ITqconid x)) = x
+getQVARSYM (L _ (ITqvarsym x)) = x
+getQCONSYM (L _ (ITqconsym x)) = x
+getIPDUPVARID (L _ (ITdupipvarid x)) = x
+getLABELVARID (L _ (ITlabelvarid x)) = x
+getCHAR (L _ (ITchar _ x)) = x
+getSTRING (L _ (ITstring _ x)) = x
+getINTEGER (L _ (ITinteger x)) = x
+getRATIONAL (L _ (ITrational x)) = x
+getPRIMCHAR (L _ (ITprimchar _ x)) = x
+getPRIMSTRING (L _ (ITprimstring _ x)) = x
+getPRIMINTEGER (L _ (ITprimint _ x)) = x
+getPRIMWORD (L _ (ITprimword _ x)) = x
+getPRIMFLOAT (L _ (ITprimfloat x)) = x
+getPRIMDOUBLE (L _ (ITprimdouble x)) = x
+getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
+
+getDOCNEXT (L _ (ITdocCommentNext x)) = x
+getDOCPREV (L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
+
+getINTEGERs (L _ (ITinteger (IL src _ _))) = src
+getCHARs (L _ (ITchar src _)) = src
+getSTRINGs (L _ (ITstring src _)) = src
+getPRIMCHARs (L _ (ITprimchar src _)) = src
+getPRIMSTRINGs (L _ (ITprimstring src _)) = src
+getPRIMINTEGERs (L _ (ITprimint src _)) = src
+getPRIMWORDs (L _ (ITprimword src _)) = src
-- See Note [Pragma source text] in BasicTypes for the following
-getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src
-getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src
-getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src
-getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src
-getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src
-getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src
-getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src
-getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src
-getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src
-getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src
-getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src
-getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src
-getANN_PRAGs (dL->L _ (ITann_prag src)) = src
-getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src
-getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src
-getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src
-getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src
-getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src
-getCTYPEs (dL->L _ (ITctype src)) = src
+getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src
+getSPEC_PRAGs (L _ (ITspec_prag src)) = src
+getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src
+getSOURCE_PRAGs (L _ (ITsource_prag src)) = src
+getRULES_PRAGs (L _ (ITrules_prag src)) = src
+getWARNING_PRAGs (L _ (ITwarning_prag src)) = src
+getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src
+getSCC_PRAGs (L _ (ITscc_prag src)) = src
+getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src
+getCORE_PRAGs (L _ (ITcore_prag src)) = src
+getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src
+getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src
+getANN_PRAGs (L _ (ITann_prag src)) = src
+getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src
+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
+getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src
+getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src
+getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
+getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
isUnicode :: Located Token -> Bool
-isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax
-isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax
isUnicode _ = False
hasE :: Located Token -> Bool
-hasE (dL->L _ (ITopenExpQuote HasE _)) = True
-hasE (dL->L _ (ITopenTExpQuote HasE)) = True
+hasE (L _ (ITopenExpQuote HasE _)) = True
+hasE (L _ (ITopenTExpQuote HasE)) = True
hasE _ = False
getSCC :: Located Token -> P FastString
@@ -3879,39 +3857,36 @@ getSCC lt = do let s = getSTRING lt
else return s
-- Utilities for combining source spans
-comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
+comb2 :: Located a -> Located b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
-comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> c -> SrcSpan
+comb3 :: Located a -> Located b -> Located c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
-comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) =>
- a -> b -> c -> d -> SrcSpan
+comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
combineSrcSpans (getLoc c) (getLoc d))
-- strict constructor version:
{-# INLINE sL #-}
-sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
-sL span a = span `seq` a `seq` cL span a
+sL :: SrcSpan -> a -> Located a
+sL span a = span `seq` a `seq` L span a
-- See Note [Adding location info] for how these utility functions are used
-- replaced last 3 CPP macros in this file
{-# INLINE sL0 #-}
-sL0 :: HasSrcSpan a => SrcSpanLess a -> a
-sL0 = cL noSrcSpan -- #define L0 L noSrcSpan
+sL0 :: a -> Located a
+sL0 = L noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
-sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b
+sL1 :: Located a -> b -> Located b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
-sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
- a -> b -> SrcSpanLess c -> c
+sLL :: Located a -> Located b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{- Note [Adding location info]
@@ -4012,37 +3987,33 @@ in ApiAnnotation.hs
-- |Construct an AddAnn from the annotation keyword and the location
-- of the keyword itself
-mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
+mj :: AnnKeywordId -> Located 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
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddAnn
-mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l
+mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
-gl :: HasSrcSpan a => a -> SrcSpan
+gl :: Located a -> SrcSpan
gl = getLoc
-- |Add an annotation to the located element, and return the located
-- element as a pass through
-aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a
-aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a
+aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a)
+aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
-- |Add an annotation to a located element resulting from a monadic action
-am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a
+am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
am a (b,s) = do
- av@(dL->L l _) <- a
+ av@(L l _) <- a
addAnnotation l b (gl s)
return av
@@ -4059,27 +4030,27 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a
-ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
+ams a@(L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
amsL sp bs = addAnnsAt sp bs >> return ()
-- |Add all [AddAnn] to an AST element, and wrap it in a 'Just'
-ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a)
+ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a))
ajs a bs = Just <$> ams a bs
-- |Add a list of AddAnns to the given AST element, where the AST element is the
-- result of a monadic action
-amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a
-amms a bs = do { av@(dL->L l _) <- a
+amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a)
+amms a bs = do { av@(L l _) <- a
; addAnnsAt l bs
; return av }
-- |Add a list of AddAnns to the AST element, and return the element as a
-- OrdList
-amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a)
-amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a)
+amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddAnn
@@ -4101,22 +4072,22 @@ 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
+oll :: OrdList (Located a) -> SrcSpan
oll l =
if isNilOL l then noSrcSpan
else getLoc (lastOL l)
-- |Add a semicolon annotation in the right place in a list. If the
-- leading list is empty, add it to the tail
-asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P()
-asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls
-asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
+asl :: [Located a] -> Located b -> Located a -> P ()
+asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls
+asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
}
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index cb70078fd3..0ffad547a7 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
@@ -162,10 +160,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
-- *** See Note [The Naming story] in GHC.Hs.Decls ****
mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d)
+mkTyClD (L loc d) = L loc (TyClD noExtField d)
mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
-mkInstD (dL->L loc d) = cL loc (InstD noExtField d)
+mkInstD (L loc d) = L loc (InstD noExtField d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
@@ -173,21 +171,21 @@ mkClassDecl :: SrcSpan
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
-mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
- , tcdLName = cls, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdFDs = snd (unLoc fds)
- , tcdSigs = mkClassOpSigs sigs
- , tcdMeths = binds
- , tcdATs = ats, tcdATDefs = at_defs
- , tcdDocs = docs })) }
+ ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt
+ , tcdLName = cls, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdFDs = snd (unLoc fds)
+ , tcdSigs = mkClassOpSigs sigs
+ , tcdMeths = binds
+ , tcdATs = ats, tcdATDefs = at_defs
+ , tcdDocs = docs })) }
mkTyData :: SrcSpan
-> NewOrData
@@ -197,17 +195,17 @@ mkTyData :: SrcSpan
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
-mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
+mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataDecl { tcdDExt = noExtField,
- tcdLName = tc, tcdTyVars = tyvars,
- tcdFixity = fixity,
- tcdDataDefn = defn })) }
+ ; return (L loc (DataDecl { tcdDExt = noExtField,
+ tcdLName = tc, tcdTyVars = tyvars,
+ tcdFixity = fixity,
+ tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
@@ -236,10 +234,10 @@ mkTySynonym loc lhs rhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (SynDecl { tcdSExt = noExtField
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; return (L loc (SynDecl { tcdSExt = noExtField
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
@@ -249,7 +247,7 @@ mkStandaloneKindSig
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
- ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
+ ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
@@ -294,7 +292,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -306,7 +304,7 @@ mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
- = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
+ = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
@@ -319,7 +317,7 @@ mkFamDecl loc info lhs ksig injAnn
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
- ; return (cL loc (FamDecl noExtField (FamilyDecl
+ ; return (L loc (FamDecl noExtField (FamilyDecl
{ fdExt = noExtField
, fdInfo = info, fdLName = tc
, fdTyVars = tyvars
@@ -342,15 +340,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
--
-- Typed splices are not allowed at the top level, thus we do not represent them
-- as spliced declaration. See #10945
-mkSpliceDecl lexpr@(dL->L loc expr)
+mkSpliceDecl lexpr@(L loc expr)
| HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
- = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
+ = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)
| otherwise
- = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr))
+ = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
@@ -359,16 +357,16 @@ mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
- ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' }
+ ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
possible_roles = [(fsFromRole role, role) | role <- all_roles]
- parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing
- parse_role (dL->L loc_role (Just role))
+ parse_role (L loc_role Nothing) = return $ L loc_role Nothing
+ parse_role (L loc_role (Just role))
= case lookup role possible_roles of
- Just found_role -> return $ cL loc_role $ Just found_role
+ Just found_role -> return $ L loc_role $ Just found_role
Nothing ->
let nearby = fuzzyLookup (unpackFS role)
(mapFst unpackFS possible_roles)
@@ -376,8 +374,6 @@ mkRoleAnnotDecl loc tycon roles
addFatalError loc_role
(text "Illegal role name" <+> quotes (ppr role) $$
suggestions nearby)
- parse_role _ = panic "parse_role: Impossible Match"
- -- due to #15884
suggestions [] = empty
suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)
@@ -402,9 +398,9 @@ cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
go [] = []
- go ((dL->L l (ValD x b)) : ds)
- = cL l' (ValD x b') : go ds'
- where (dL->L l' b', ds') = getMonoBind (cL l b) ds
+ go ((L l (ValD x b)) : ds)
+ = L l' (ValD x b') : go ds'
+ where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
-- Declaration list may only contain value bindings and signatures.
@@ -424,24 +420,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
- go ((dL->L l (ValD _ b)) : ds)
+ go ((L l (ValD _ b)) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
where
- (b', ds') = getMonoBind (cL l b) ds
- go ((dL->L l decl) : ds)
+ (b', ds') = getMonoBind (L l b) ds
+ go ((L l decl) : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
SigD _ s
- -> return (bs, cL l s : ss, ts, tfis, dfis, docs)
+ -> return (bs, L l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
- -> return (bs, ss, cL l t : ts, tfis, dfis, docs)
+ -> return (bs, ss, L l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
- -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs)
+ -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
- -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs)
+ -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
DocD _ d
- -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
+ -> return (bs, ss, ts, tfis, dfis, L l d : docs)
SpliceD _ d
-> addFatalError l $
hang (text "Declaration splices are allowed only" <+>
@@ -467,25 +463,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs1) } }))
+getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs1) } }))
binds
| has_args mtchs1
= go mtchs1 loc1 binds []
where
go mtchs loc
- ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2)
- , fun_matches =
- MG { mg_alts = (dL->L _ mtchs2) } })))
+ ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
+ , fun_matches =
+ MG { mg_alts = (L _ mtchs2) } })))
: binds) _
| f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds []
- go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls
+ go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
- = ( cL loc (makeFunBind fun_id1 (reverse mtchs))
+ = ( L loc (makeFunBind fun_id1 (reverse mtchs))
, (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments
@@ -493,14 +489,13 @@ getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1)
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
-has_args [] = panic "RdrHsSyn:has_args"
-has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args)
+has_args [] = panic "RdrHsSyn:has_args"
+has_args (L _ (Match { m_pats = args }) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
-- than pattern bindings (tests/rename/should_fail/rnfail002).
-has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec
-has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884
+has_args (L _ (XMatch nec) : _) = noExtCon nec
{- **********************************************************************
@@ -564,14 +559,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
+For example, both occurrences 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
@@ -592,7 +586,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
tyConToDataCon loc tc
| isTcOcc occ || isDataOcc occ
, isLexCon (occNameFS occ)
- = return (cL loc (setRdrNameSpace tc srcDataName))
+ = return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
= Left (loc, msg)
@@ -603,14 +597,14 @@ tyConToDataCon loc tc
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
-mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
+mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
- fromDecl (dL->L loc decl@(ValD _ (PatBind _
- pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details))
- rhs _))) =
+ fromDecl (L loc decl@(ValD _ (PatBind _
+ pat@(L _ (ConPatIn ln@(L _ name) details))
+ rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
@@ -632,8 +626,8 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
, mc_strictness = NoSrcStrict }
RecCon{} -> recordPatSynErr loc pat
- ; return $ cL loc match }
- fromDecl (dL->L loc decl) = extraDeclErr loc decl
+ ; return $ L loc match }
+ fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
addFatalError loc $
@@ -675,7 +669,7 @@ mkGadtDecl :: [Located RdrName]
mkGadtDecl names ty
= (ConDeclGADT { con_g_ext = noExtField
, con_names = names
- , con_forall = cL l $ isLHsForAllTy ty'
+ , con_forall = L l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args
@@ -683,13 +677,13 @@ mkGadtDecl names ty
, con_doc = Nothing }
, anns1 ++ anns2)
where
- (ty'@(dL->L l _),anns1) = peel_parens ty []
+ (ty'@(L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTyInvis ty'
(mcxt, tau, anns2) = split_rho rho []
- split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+ split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
= (Just cxt, tau, ann)
- split_rho (dL->L l (HsParTy _ ty)) ann
+ split_rho (L l (HsParTy _ ty)) ann
= split_rho ty (ann++mkParensApiAnn l)
split_rho tau ann
= (Nothing, tau, ann)
@@ -697,12 +691,12 @@ mkGadtDecl names ty
(args, res_ty) = split_tau tau
-- See Note [GADT abstract syntax] in GHC.Hs.Decls
- split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
- = (RecCon (cL loc rf), res_ty)
+ split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
+ = (RecCon (L loc rf), res_ty)
split_tau tau
= (PrefixCon [], tau)
- peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty
+ peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
@@ -826,19 +820,18 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddAnn] -> LHsType GhcPs
-> P (LHsTyVarBndr GhcPs, [AddAnn])
- chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l
- ++ acc) ty
+ chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty
chkParens acc ty = do
tv <- chk ty
return (tv, reverse acc)
-- Check that the name space is correct!
chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs)
- chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k))
- | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k))
- chk (dL->L l (HsTyVar _ _ (dL->L ltv tv)))
- | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv)))
- chk t@(dL->L loc _)
+ chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k))
+ chk (L l (HsTyVar _ _ (L ltv tv)))
+ | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv)))
+ chk t@(L loc _)
= addFatalError loc $
vcat [ text "Unexpected type" <+> quotes (ppr t)
, text "In the" <+> pp_what
@@ -896,14 +889,14 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one)
-- See note [Parsing explicit foralls in Rules] in Parser.y
checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
- where check (dL->L loc (Unqual occ)) = do
+ where check (L loc (Unqual occ)) = do
when ((occNameString occ ==) `any` ["forall","family","role"])
(addFatalError loc (text $ "parse error on input "
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
-checkRecordSyntax lr@(dL->L loc r)
+checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $
text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
@@ -913,7 +906,7 @@ checkRecordSyntax lr@(dL->L loc r)
-- `data T where` to avoid affecting existing error message, see #8258.
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
+checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
unless gadtSyntax $ addError span $ vcat
[ text "Illegal keyword 'where' in data declaration"
@@ -937,23 +930,23 @@ checkTyClHdr :: Bool -- True <=> class header
checkTyClHdr is_cls ty
= goL ty [] [] Prefix
where
- goL (dL->L l ty) acc ann fix = go l ty acc ann fix
+ goL (L l ty) acc ann fix = go l ty acc ann fix
-- workaround to define '*' despite StarIsType
- go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix
+ go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
= do { warnStarBndr l
; let name = mkOccName tcClsName (starSym isUni)
- ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
+ ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
- go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix
+ go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix
| isRdrTc tc = return (ltc, acc, fix, ann)
- go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
- = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
+ = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
@@ -990,7 +983,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
HsCmdDo {} -> check "do command" cmd
_ -> return ()
- check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
+ check :: Outputable a => String -> Located a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
@@ -1010,22 +1003,22 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
-- (((Eq a))) --> [Eq a]
-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
-checkContext (dL->L l orig_t)
- = check [] (cL l orig_t)
+checkContext (L l orig_t)
+ = check [] (L l orig_t)
where
- check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+ check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
-- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
-- be used as context constraints.
- = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto ()
+ = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
- check anns (dL->L lp1 (HsParTy _ ty))
+ check anns (L lp1 (HsParTy _ ty))
-- to be sure HsParTy doesn't get into the way
= check anns' ty
where anns' = if l == lp1 then anns
else (anns ++ mkParensApiAnn lp1)
-- no need for anns, returning original
- check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t])
+ check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
msg = text "data constructor context"
@@ -1034,9 +1027,9 @@ checkContext (dL->L l orig_t)
checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
checkNoDocs msg ty = go ty
where
- go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
- go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
- go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep
+ go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
+ go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+ go (L l (HsDocTy _ t ds)) = addError l $ hsep
[ text "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ]
go _ = pure ()
@@ -1079,27 +1072,21 @@ checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(dL->L l _) = checkPat l e []
+checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
-checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args
- | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
+checkPat loc (L l e@(PatBuilderVar (L _ c))) args
+ | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon 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
+checkPat loc (L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
-checkPat loc (dL->L _ e) []
+checkPat loc (L _ e) []
= do p <- checkAPat loc e
- return (cL loc p)
+ return (L loc p)
checkPat loc e _
= patFail loc (ppr e)
@@ -1113,27 +1100,21 @@ checkAPat loc e0 = do
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
-- 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') }
+ PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
-- n+k patterns
PatBuilderOpApp
- (dL->L nloc (PatBuilderVar (dL->L _ n)))
- (dL->L _ plus)
- (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+ (L nloc (PatBuilderVar (L _ n)))
+ (L _ plus)
+ (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR)
- -> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
+ -> return (mkNPlusKPat (L nloc n) (L lloc lit))
- PatBuilderOpApp l (dL->L cl c) r
+ PatBuilderOpApp l (L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
- return (ConPatIn (cL cl c) (InfixCon l r))
+ return (ConPatIn (L cl c) (InfixCon l r))
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField))
_ -> patFail loc (ppr e0)
@@ -1148,15 +1129,10 @@ 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)
- return (cL l (fld { hsRecFieldArg = p }))
+checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
+ return (L l (fld { hsRecFieldArg = p }))
patFail :: SrcSpan -> SDoc -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
@@ -1167,23 +1143,22 @@ 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@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
- checkFunBind strictness ann (getLoc lhs)
- fun is_infix pats (cL l grhss)
+ checkFunBind NoSrcStrict ann (getLoc lhs)
+ fun is_infix pats (L l grhss)
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
@@ -1196,19 +1171,19 @@ checkFunBind :: SrcStrictness
-> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
+checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
return (ann, makeFunBind fun
- [cL match_span (Match { m_ext = noExtField
- , m_ctxt = FunRhs
- { mc_fun = fun
- , mc_fixity = is_infix
- , mc_strictness = strictness }
- , m_pats = ps
- , m_grhss = grhss })])
+ [L match_span (Match { m_ext = noExtField
+ , m_ctxt = FunRhs
+ { mc_fun = fun
+ , mc_fixity = is_infix
+ , mc_strictness = strictness }
+ , m_pats = ps
+ , m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
@@ -1222,19 +1197,32 @@ 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 _ (_,grhss))
+checkPatBind lhs (L match_span (_,grhss))
+ | BangPat _ p <- unLoc lhs
+ , VarPat _ v <- unLoc p
+ = return ([], makeFunBind v [L match_span (m v)])
+ where
+ m v = Match { m_ext = noExtField
+ , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v)
+ , mc_fixity = Prefix
+ , mc_strictness = SrcStrict }
+ , m_pats = []
+ , m_grhss = grhss }
+
+checkPatBind lhs (L _ (_,grhss))
= return ([],PatBind noExtField lhs grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
-checkValSigLhs lhs@(dL->L l _)
+checkValSigLhs lhs@(L l _)
= addFatalError l ((text "Invalid type signature:" <+>
ppr lhs <+> text ":: ...")
$$ text hint)
@@ -1252,8 +1240,8 @@ checkValSigLhs lhs@(dL->L l _)
-- so check for that, and suggest. cf #3805
-- Sadly 'foreign import' still barfs 'parse error' because
-- 'import' is a keyword
- looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s
- looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs
+ looks_like s (L _ (HsVar _ (L _ v))) = v == s
+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
@@ -1261,8 +1249,8 @@ checkValSigLhs lhs@(dL->L l _)
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse
- :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
- => a -> Bool -> b -> Bool -> c -> PV ()
+ :: (Outputable a, Outputable b, Outputable c)
+ => Located a -> Bool -> b -> Bool -> Located c -> PV ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
@@ -1278,77 +1266,27 @@ 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]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
---
--- The whole LHS is parsed as a single expression.
--- Any infix operators on the LHS will parse left-associatively
--- E.g. f !x y !z
--- will parse (rather strangely) as
--- (f ! x y) ! z
--- It's up to isFunLhs to sort out the mess
---
--- a .!. !b
-
isFunLhs e = go e [] []
where
- go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann
- | 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 (L loc (PatBuilderVar (L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
+ go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (cL loc' op, Infix, (l:r:es), ann))
+ = return (Just (L loc' op, Infix, (l:r:es), ann))
| otherwise -- Infix data con; keep going
= do { mb_l <- go l es ann
; case mb_l of
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
- op_app = cL loc (PatBuilderOpApp k
- (cL loc' op) r)
+ op_app = L loc (PatBuilderOpApp k
+ (L loc' op) r)
_ -> return Nothing }
go _ _ _ = return Nothing
@@ -1356,7 +1294,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 +1316,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 (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
@@ -1421,13 +1340,24 @@ pBangTy
, LHsType GhcPs {- the resulting BangTy -}
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(dL->L l1 _) xs =
- case pStrictMark xs of
+pBangTy lt@(L l1 _) xs =
+ 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
- in (True, cL bl bt, addAnnsAt bl anns, xs')
+ bt = addUnpackedness (prag, unpk) lt
+ in (True, L 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.
@@ -1442,8 +1372,8 @@ pBangTy lt@(dL->L l1 _) xs =
--
-- See Note [Parsing data constructors is hard]
mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
-mergeOps ((dL->L l1 (TyElOpd t)) : xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs
+mergeOps ((L l1 (TyElOpd t)) : xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
, null xs' -- We accept a BangTy only when there are no preceding TyEl.
= addAnns >> return t'
mergeOps all_xs = go (0 :: Int) [] id all_xs
@@ -1453,7 +1383,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [unpk]:
-- handle (NO)UNPACK pragmas
- go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
+ go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
if not (null acc) && null xs
then do { acc' <- eitherToP $ mergeOpsAcc acc
; let a = ops_acc acc'
@@ -1461,7 +1391,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
bl = combineSrcSpans l (getLoc a)
bt = HsBangTy noExtField strictMark a
; addAnnsAt bl anns
- ; return (cL bl bt) }
+ ; return (L bl bt) }
else addFatalError l unpkError
where
unpkSDoc = case unpkSrc of
@@ -1476,68 +1406,35 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
-- clause [doc]:
-- we do not expect to encounter any docs
- go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
+ go _ _ _ ((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
-- to build its lhs.
- go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
+ go k acc ops_acc ((L l (TyElOpr op)):xs) =
if null acc || null (filter isTyElOpd xs)
- then failOpFewArgs (cL l op)
+ then failOpFewArgs (L l op)
else do { acc' <- eitherToP (mergeOpsAcc acc)
- ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
+ ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }
where
- isTyElOpd (dL->L _ (TyElOpd _)) = True
+ isTyElOpd (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
+ go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs
-- clause [tyapp]:
-- whenever a type application is encountered, it is added to the accumulator
- go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
+ go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-- clause [end]
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
- go _ _ _ _ = panic "mergeOps.go: Impossible Match"
- -- due to #15884
-
mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
@@ -1609,8 +1506,8 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
-}
pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
-pInfixSide ((dL->L l (TyElOpd t)):xs)
- | (True, t', addAnns, xs') <- pBangTy (cL l t) xs
+pInfixSide ((L l (TyElOpd t)):xs)
+ | (True, t', addAnns, xs') <- pBangTy (L l t) xs
= Just (t', addAnns, xs')
pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
@@ -1627,84 +1524,29 @@ pInfixSide (el:xs1)
pInfixSide _ = Nothing
pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
-pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
-pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
+pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))
+pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
pDocPrev = go Nothing
where
- go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) =
- go (mTrailingDoc `mplus` Just (cL l doc)) xs
+ go mTrailingDoc ((L l (TyElDocPrev doc)):xs) =
+ go (mTrailingDoc `mplus` Just (L l doc)) xs
go mTrailingDoc xs = (mTrailingDoc, xs)
orErr :: Maybe a -> b -> Either b a
orErr (Just a) _ = Right a
orErr Nothing b = Left b
-{- Note [isFunLhs vs mergeDataCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When parsing a function LHS, we do not know whether to treat (!) as
-a strictness annotation or an infix operator:
-
- f ! a = ...
-
-Without -XBangPatterns, this parses as (!) f a = ...
- with -XBangPatterns, this parses as f (!a) = ...
-
-So in function declarations we opted to always parse as if -XBangPatterns
-were off, and then rejig in 'isFunLhs'.
-
-There are two downsides to this approach:
-
-1. It is not particularly elegant, as there's a point in our pipeline where
- the representation is awfully incorrect. For instance,
- f !a b !c = ...
- will be first parsed as
- (f ! a b) ! c = ...
-
-2. There are cases that it fails to cover, for instance infix declarations:
- !a + !b = ...
- will trigger an error.
-
-Unfortunately, we cannot define different productions in the 'happy' grammar
-depending on whether -XBangPatterns are enabled.
-
-When parsing data constructors, we face a similar issue:
- (a) data T1 = C ! D
- (b) data T2 = C ! D => ...
-
-In (a) the first bang is a strictness annotation, but in (b) it is a type
-operator. A 'happy'-based parser does not have unlimited lookahead to check for
-=>, so we must first parse (C ! D) into a common representation.
-
-If we tried to mirror the approach used in functions, we would parse both sides
-of => as types, and then rejig. However, we take a different route and use an
-intermediate data structure, a reversed list of 'TyEl'.
-See Note [Parsing data constructors is hard] for details.
-
-This approach does not suffer from the issues of 'isFunLhs':
-
-1. A sequence of 'TyEl' is a dedicated intermediate representation, not an
- incorrectly parsed type. Therefore, we do not have confusing states in our
- pipeline. (Except for representing data constructors as type variables).
-
-2. We can handle infix data constructors with strictness annotations:
- data T a b = !a :+ !b
-
--}
-
-
-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
-- 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]
--- See Note [isFunLhs vs mergeDataCon]
mergeDataCon
:: [Located TyEl]
-> P ( Located RdrName -- constructor name
@@ -1733,7 +1575,7 @@ mergeDataCon all_xs =
-- A -- ^ Comment on A
-- B -- ^ Comment on B (singleDoc == False)
singleDoc = isJust mTrailingDoc &&
- null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ]
+ null [ () | (L _ (TyElDocPrev _)) <- all_xs' ]
-- The result of merging the list of reversed TyEl into a
-- data constructor, along with [AddAnn].
@@ -1755,38 +1597,38 @@ mergeDataCon all_xs =
trailingFieldDoc | singleDoc = Nothing
| otherwise = mTrailingDoc
- goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) }
- goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs)
+ goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)
| (mConDoc, xs') <- pDocPrev xs
- , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs'
+ , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs'
= do { data_con <- tyConToDataCon l' tc
; let mDoc = mTrailingDoc `mplus` mConDoc
- ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) }
- goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
+ ; return (pure (), (data_con, RecCon (L l fields), mDoc)) }
+ goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
= return ( pure ()
- , ( cL l (getRdrName (tupleDataCon Boxed (length ts)))
+ , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
, PrefixCon ts
, mTrailingDoc ) )
- goFirst ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns, xs') <- pBangTy (cL l t) xs
+ goFirst ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns, xs') <- pBangTy (L l t) xs
= go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
goFirst (L l (TyElKindApp _ _):_)
= goInfix Monoid.<> Left (l, kindAppErr)
goFirst xs
= go (pure ()) mTrailingDoc [] xs
- go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
+ go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
= do { data_con <- tyConToDataCon l tc
; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) }
- go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) =
- go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs
- go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs)
- | (_, t', addAnns', xs') <- pBangTy (cL l t) xs
+ go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) =
+ go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs
+ go addAnns mLastDoc ts ((L l (TyElOpd t)):xs)
+ | (_, t', addAnns', xs') <- pBangTy (L l t) xs
, t'' <- mkLHsDocTyMaybe t' mLastDoc
= go (addAnns >> addAnns') Nothing (t'':ts) xs'
- go _ _ _ ((dL->L _ (TyElOpr _)):_) =
+ go _ _ _ ((L _ (TyElOpr _)):_) =
-- Encountered an operator: backtrack to the beginning and attempt
-- to parse as an infix definition.
goInfix
@@ -1804,7 +1646,7 @@ mergeDataCon all_xs =
; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
; let (mOpDoc, xs2) = pDocPrev xs1
; (op, xs3) <- case xs2 of
- (dL->L l (TyElOpr op)) : xs3 ->
+ (L l (TyElOpr op)) : xs3 ->
do { data_con <- tyConToDataCon l op
; return (data_con, xs3) }
_ -> Left malformedErr
@@ -1847,6 +1689,17 @@ checkMonadComp = do
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
+--
+-- This newtype is required to avoid impredicative types in monadic
+-- productions. That is, in a production that looks like
+--
+-- | ... {% return (ECP ...) }
+--
+-- we are dealing with
+-- P ECP
+-- whereas without a newtype we would be dealing with
+-- P (forall b. DisambECP b => PV (Located b))
+--
newtype ECP =
ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
@@ -1866,14 +1719,14 @@ class DisambInfixOp b where
mkHsConOpPV :: Located RdrName -> PV (Located b)
mkHsInfixHolePV :: SrcSpan -> PV (Located b)
-instance p ~ GhcPs => DisambInfixOp (HsExpr p) where
- mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v)
- mkHsInfixHolePV l = return $ cL l hsHoleExpr
+instance DisambInfixOp (HsExpr GhcPs) where
+ mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsInfixHolePV l = return $ L l hsHoleExpr
instance DisambInfixOp RdrName where
- mkHsConOpPV (dL->L l v) = return $ cL l v
- mkHsVarOpPV (dL->L l v) = return $ cL l v
+ mkHsConOpPV (L l v) = return $ L l v
+ mkHsVarOpPV (L l v) = return $ L l v
mkHsInfixHolePV l =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
@@ -1893,7 +1746,7 @@ class b ~ (Body b) GhcPs => DisambECP b where
mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)
-- | Infix operator representation
type InfixOp b
- -- | Bring superclass constraints on FunArg into scope.
+ -- | Bring superclass constraints on InfixOp into scope.
-- See Note [UndecidableSuperClasses for associated types]
superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b)
-- | Disambiguate "f # x" (infix operator)
@@ -1950,11 +1803,15 @@ 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)
{- Note [UndecidableSuperClasses for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This Note is about the code in GHC, not about the user code that we are parsing)
+
Assume we have a class C with an associated type T:
class C a where
@@ -1995,37 +1852,37 @@ PatBuilder, but leads to worse type inference, breaking some code in the
typechecker.
-}
-instance p ~ GhcPs => DisambECP (HsCmd p) where
- type Body (HsCmd p) = HsCmd
+instance DisambECP (HsCmd GhcPs) where
+ type Body (HsCmd GhcPs) = HsCmd
ecpFromCmd' = return
- ecpFromExp' (dL-> L l e) = cmdFail l (ppr e)
- mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg)
- mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e)
- type InfixOp (HsCmd p) = HsExpr p
+ ecpFromExp' (L l e) = cmdFail l (ppr e)
+ mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)
+ mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)
+ type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
- let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c
- return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
- mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg)
- type FunArg (HsCmd p) = HsExpr p
+ let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c
+ return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]
+ mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg)
+ type FunArg (HsCmd GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l c e = do
checkCmdBlockArguments c
checkExpBlockArguments e
- return $ cL l (HsCmdApp noExtField c e)
+ return $ L l (HsCmdApp noExtField c e)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsCmdIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts)
- mkHsParPV l c = return $ cL l (HsCmdPar noExtField c)
- mkHsVarPV (dL->L l v) = cmdFail l (ppr v)
- mkHsLitPV (dL->L l a) = cmdFail l (ppr a)
- mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a)
+ return $ L l (mkHsCmdIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts)
+ mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
+ mkHsVarPV (L l v) = cmdFail l (ppr v)
+ mkHsLitPV (L l a) = cmdFail l (ppr a)
+ mkHsOverLitPV (L l a) = cmdFail l (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig)
mkHsExplicitListPV l xs = cmdFail l $
brackets (fsep (punctuate comma (map ppr xs)))
- mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp)
+ mkHsSplicePV (L l sp) = cmdFail l (ppr sp)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
@@ -2039,68 +1896,69 @@ 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
cmdFail loc e = addFatalError loc $
hang (text "Parse error in command:") 2 (ppr e)
-instance p ~ GhcPs => DisambECP (HsExpr p) where
- type Body (HsExpr p) = HsExpr
- ecpFromCmd' (dL -> L l c) = do
+instance DisambECP (HsExpr GhcPs) where
+ type Body (HsExpr GhcPs) = HsExpr
+ ecpFromCmd' (L l c) = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
- return (cL l hsHoleExpr)
+ return (L l hsHoleExpr)
ecpFromExp' = return
- mkHsLamPV l mg = return $ cL l (HsLam noExtField mg)
- mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c)
- type InfixOp (HsExpr p) = HsExpr p
+ mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
+ mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)
+ type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
- return $ cL l $ OpApp noExtField e1 op e2
- mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg)
- type FunArg (HsExpr p) = HsExpr p
+ return $ L l $ OpApp noExtField e1 op e2
+ mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)
+ type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l e1 e2 = do
checkExpBlockArguments e1
checkExpBlockArguments e2
- return $ cL l (HsApp noExtField e1 e2)
+ return $ L l (HsApp noExtField e1 e2)
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
- return $ cL l (mkHsIf c a b)
- mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts)
- mkHsParPV l e = return $ cL l (HsPar noExtField e)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v)
- mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a)
- mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a)
- mkHsWildCardPV l = return $ cL l hsHoleExpr
- mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
- mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs)
+ return $ L l (mkHsIf c a b)
+ mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts)
+ mkHsParPV l e = return $ L l (HsPar noExtField e)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)
+ mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
+ mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
+ mkHsWildCardPV l = return $ L l hsHoleExpr
+ mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
+ mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
- 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
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
+ mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
+ 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) }
+ ; return (L l hsHoleExpr) }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
@@ -2108,21 +1966,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
@@ -2131,10 +1982,10 @@ instance Outputable (PatBuilder GhcPs) where
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
- ecpFromCmd' (dL-> L l c) =
+ ecpFromCmd' (L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
- ecpFromExp' (dL-> L l e) =
+ ecpFromExp' (L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
mkHsLamPV l _ = addFatalError l $
@@ -2143,53 +1994,54 @@ 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 $ L l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
- mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2)
+ mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
- mkHsParPV l p = return $ cL l (PatBuilderPar p)
- mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v)
- mkHsLitPV lit@(dL->L l a) = do
+ mkHsParPV l p = return $ L l (PatBuilderPar p)
+ mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
+ mkHsLitPV lit@(L l a) = do
checkUnboxedStringLitPat lit
- return $ cL l (PatBuilderPat (LitPat noExtField a))
- mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a)
- mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField))
+ return $ L l (PatBuilderPat (LitPat noExtField a))
+ mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
+ mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
mkHsTySigPV l b sig = do
p <- checkLPat b
- return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
+ return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
- return (cL l (PatBuilderPat (ListPat noExtField ps)))
- mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp))
+ return (L l (PatBuilderPat (ListPat noExtField ps)))
+ mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV l _ a (fbinds, ddLoc) = do
r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
- checkRecordSyntax (cL l r)
- mkHsNegAppPV l (dL->L lp p) = do
+ checkRecordSyntax (L l r)
+ mkHsNegAppPV l (L lp p) = do
lit <- case p of
- PatBuilderOverLit pos_lit -> return (cL lp pos_lit)
+ PatBuilderOverLit pos_lit -> return (L 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)
+ return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
+ 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))
+ return $ L l (PatBuilderPat (ViewPat noExtField a p))
mkHsAsPatPV l v e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (AsPat noExtField v p))
+ return $ L l (PatBuilderPat (AsPat noExtField v p))
mkHsLazyPatPV l e = do
p <- checkLPat e
- return $ cL l (PatBuilderPat (LazyPat noExtField p))
+ return $ L l (PatBuilderPat (LazyPat noExtField p))
+ mkHsBangPatPV l e = do
+ p <- checkLPat e
+ let pb = BangPat noExtField p
+ hintBangPat l pb
+ return $ L l (PatBuilderPat pb)
mkSumOrTuplePV = mkSumOrTuplePat
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
-checkUnboxedStringLitPat (dL->L loc lit) =
+checkUnboxedStringLitPat (L loc lit) =
case lit of
HsStringPrim _ _ -- Trac #13260
-> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
@@ -2206,19 +2058,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2243,12 +2082,12 @@ Guards:
Top-level value/function declarations (FunBind/PatBind):
- f !a -- TH splice
- f !a = ... -- function declaration
+ f ! a -- TH splice
+ f ! a = ... -- function declaration
Until we encounter the = sign, we don't know if it's a top-level
- TemplateHaskell splice where ! is an infix operator, or if it's a function
- declaration where ! is a strictness annotation.
+ TemplateHaskell splice where ! is used, or if it's a function declaration
+ where ! is bound.
There are also places in the grammar where we do not know whether we are
parsing an expression or a command:
@@ -2274,9 +2113,9 @@ or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):
class DisambECP b where ...
- instance p ~ GhcPs => DisambECP (HsCmd p) where ...
- instance p ~ GhcPs => DisambECP (HsExp p) where ...
- instance p ~ GhcPs => DisambECP (PatBuilder p) where ...
+ instance DisambECP (HsCmd GhcPs) where ...
+ instance DisambECP (HsExp GhcPs) where ...
+ instance DisambECP (PatBuilder GhcPs) where ...
The 'DisambECP' class contains functions to build and validate 'b'. For example,
to add parentheses we have:
@@ -2310,6 +2149,12 @@ Compared to the initial definition, the added bits are:
The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions.
+Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding
+position and shadows the previous $1. We can do this because internally
+'happy' desugars $n to happy_var_n, and the rationale behind this idiom
+is to be able to write (sLL $1 $>) later on. The alternative would be to
+write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
+to the last fresh name as $>.
-}
@@ -2337,21 +2182,6 @@ There are several issues with this:
* HsExpr is arbitrarily selected as the extension basis. Why not extend
HsCmd or HsPat with extra constructors instead?
- * We cannot handle corner cases. For instance, the following function
- declaration LHS is not a valid expression (see #1087):
-
- !a + !b = ...
-
- * There are points in the pipeline where the representation was awfully
- incorrect. For instance,
-
- f !a b !c = ...
-
- is first parsed as
-
- (f ! a b) ! c = ...
-
-
Alternative II, extra constructors in GHC.Hs.Expr for GhcPs
-----------------------------------------------------------
We could address some of the problems with Alternative I by using Trees That
@@ -2598,7 +2428,7 @@ tagless final encoding, and there's no need for this complexity.
{- Note [PatBuilder]
~~~~~~~~~~~~~~~~~~~~
-Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms,
+Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,
so we introduce the notion of a PatBuilder.
Consider a pattern like this:
@@ -2625,14 +2455,6 @@ Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have
instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for
the intermediate forms.
-Worse yet, some intermediate forms are not valid patterns at all. For example:
-
- Con !a !b c
-
-This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then
-rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid
-patterns, so we cannot represent them as Pat.
-
We also need an intermediate representation to postpone disambiguation between
FunBind and PatBind. Consider:
@@ -2657,12 +2479,6 @@ parsing results for patterns and function bindings:
It can represent any pattern via 'PatBuilderPat', but it also has a variety of
other constructors which were added by following a simple principle: we never
pattern match on the pattern stored inside 'PatBuilderPat'.
-
-For example, in 'splitBang' we need to match on space-separated and
-bang-separated patterns, so these are represented with dedicated constructors
-'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on
-variables, so we have a dedicated 'PatBuilderVar' constructor for this despite
-the existence of 'VarPat'.
-}
---------------------------------------------------------------------------
@@ -2674,7 +2490,7 @@ checkPrecP
:: Located (SourceText,Int) -- ^ precedence
-> Located (OrdList (Located RdrName)) -- ^ operators
-> P ()
-checkPrecP (dL->L l (_,i)) (dL->L _ ol)
+checkPrecP (L l (_,i)) (L _ ol)
| 0 <= i, i <= maxPrecedence = pure ()
| all specialOp ol = pure ()
| otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
@@ -2688,9 +2504,9 @@ mkRecConstrOrUpdate
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> PV (HsExpr GhcPs)
-mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
- = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
+ = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
| Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
| otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
@@ -2708,15 +2524,13 @@ mkRdrRecordCon con flds
mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
- , rec_dotdot = Just (cL s (length fs)) }
+ , rec_dotdot = Just (L s (length fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun)
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExtField rdr)) arg pun
-mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _)
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _)
= noExtCon nec
-mk_rec_upd_field (HsRecField _ _ _)
- = panic "mk_rec_upd_field: Impossible Match" -- due to #15884
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -2759,7 +2573,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of
+ case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError loc (text "Malformed entity string")
Just importSpec -> returnSpec importSpec
@@ -2771,7 +2585,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc)
+ importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
returnSpec spec = return $ ForD noExtField $ ForeignImport
{ fd_i_ext = noExtField
@@ -2846,11 +2660,11 @@ parseCImport cconv safety nm str sourceText =
mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
-mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty)
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
= return $ ForD noExtField $
ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv))
- (cL le esrc) }
+ , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
+ (L le esrc) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
@@ -2877,15 +2691,15 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName)
| ImpExpQcWildcard
mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp (dL->L l specname) subs =
+mkModuleImpExp (L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar noExtField (cL l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs noExtField . cL l <$> nameT
- ImpExpAll -> IEThingAll noExtField . cL l <$> nameT
+ -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs noExtField . L l <$> nameT
+ ImpExpAll -> IEThingAll noExtField . L l <$> nameT
ImpExpList xs ->
- (\newName -> IEThingWith noExtField (cL l newName)
+ (\newName -> IEThingWith noExtField (L l newName)
NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- getBit PatternSynonymsBit
@@ -2896,7 +2710,7 @@ mkModuleImpExp (dL->L l specname) subs =
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
- -> IEThingWith noExtField (cL l newName) pos ies [])
+ -> IEThingWith noExtField (L l newName) pos ies [])
<$> nameT
else addFatalError l
(text "Illegal export form (use PatternSynonyms to enable)")
@@ -2922,7 +2736,7 @@ mkModuleImpExp (dL->L l specname) subs =
ieNameFromSpec (ImpExpQcType ln) = IEType ln
ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"
- wrapped = map (onHasSrcSpan ieNameFromSpec)
+ wrapped = map (mapLoc ieNameFromSpec)
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
@@ -2933,8 +2747,8 @@ mkTypeImpExp name =
return (fmap (`setRdrNameSpace` tcClsName) name)
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
-checkImportSpec ie@(dL->L _ specs) =
- case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
+checkImportSpec ie@(L _ specs) =
+ case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
@@ -2946,7 +2760,7 @@ checkImportSpec ie@(dL->L _ specs) =
-- In the correct order
mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
-mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] =
+mkImpExpSubSpec [L _ ImpExpQcWildcard] =
return ([], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
@@ -2979,7 +2793,7 @@ failOpNotEnabledImportQualifiedPost loc = addError loc msg
failOpImportQualifiedTwice :: SrcSpan -> P ()
failOpImportQualifiedTwice loc = addError loc msg
where
- msg = text "Multiple occurences of 'qualified'"
+ msg = text "Multiple occurrences of 'qualified'"
warnStarIsType :: SrcSpan -> P ()
warnStarIsType span = addWarning Opt_WarnStarIsType span msg
@@ -3002,7 +2816,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
$$ text " including the definition module, you must qualify it."
failOpFewArgs :: Located RdrName -> P a
-failOpFewArgs (dL->L loc op) =
+failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let msg = too_few $$ starInfo star_is_type op
; addFatalError loc msg }
@@ -3014,18 +2828,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 +2993,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
@@ -3221,14 +3023,14 @@ mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExp
-- Tuple
mkSumOrTupleExpr l boxity (Tuple es) =
- return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity)
+ return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity)
where
toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = mapLoc (maybe missingTupArg (Present noExtField))
-- Sum
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
- return $ cL l (ExplicitSum noExtField alt arity e)
+ return $ L l (ExplicitSum noExtField alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
@@ -3238,17 +3040,17 @@ mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Loc
-- Tuple
mkSumOrTuplePat l boxity (Tuple ps) = do
ps' <- traverse toTupPat ps
- return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity))
+ return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity))
where
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
- toTupPat (dL -> L l p) = case p of
+ toTupPat (L l p) = case p of
Nothing -> addFatalError l (text "Tuple section in pattern context")
Just p' -> checkLPat p'
-- Sum
mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
- return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity))
+ return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
@@ -3256,12 +3058,12 @@ mkSumOrTuplePat l Boxed a@Sum{} =
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
- in cL loc (mkHsOpTy x op y)
+ in L loc (mkHsOpTy x op y)
mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs
mkLHsDocTy t doc =
let loc = getLoc t `combineSrcSpans` getLoc doc
- in cL loc (HsDocTy noExtField t doc)
+ in L loc (HsDocTy noExtField t doc)
mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t)
View Lorry Controller Status