summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/ApiAnnotation.hs6
-rw-r--r--compiler/parser/Ctype.hs2
-rw-r--r--compiler/parser/HaddockUtils.hs2
-rw-r--r--compiler/parser/Lexer.x545
-rw-r--r--compiler/parser/Parser.y924
-rw-r--r--compiler/parser/RdrHsSyn.hs894
-rw-r--r--compiler/parser/cutils.c17
-rw-r--r--compiler/parser/cutils.h5
8 files changed, 1435 insertions, 960 deletions
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index 34787b3399..6ae01d6fe0 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -13,6 +13,8 @@ module ApiAnnotation (
LRdrName -- Exists for haddocks only
) where
+import GhcPrelude
+
import RdrName
import Outputable
import SrcLoc
@@ -278,13 +280,13 @@ data AnnKeywordId
| AnnThIdTySplice -- ^ '$$'
| AnnThTyQuote -- ^ double '''
| AnnTilde -- ^ '~'
- | AnnTildehsh -- ^ '~#'
| AnnType
| AnnUnit -- ^ '()' for types
| AnnUsing
| AnnVal -- ^ e.g. INTEGER
| AnnValStr -- ^ String value, will need quotes when output
| AnnVbar -- ^ '|'
+ | AnnVia -- ^ 'via'
| AnnWhere
| Annlarrowtail -- ^ '-<'
| AnnlarrowtailU -- ^ '-<', unicode variant
@@ -320,7 +322,7 @@ instance Outputable AnnotationComment where
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma',
--- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh',
+-- 'ApiAnnotation.AnnRarrow'
-- 'ApiAnnotation.AnnTilde'
-- - May have 'ApiAnnotation.AnnComma' when in a list
type LRdrName = Located RdrName
diff --git a/compiler/parser/Ctype.hs b/compiler/parser/Ctype.hs
index 6423218f91..9c3988e869 100644
--- a/compiler/parser/Ctype.hs
+++ b/compiler/parser/Ctype.hs
@@ -16,6 +16,8 @@ module Ctype
#include "HsVersions.h"
+import GhcPrelude
+
import Data.Int ( Int32 )
import Data.Bits ( Bits((.&.)) )
import Data.Char ( ord, chr )
diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index 387cbf8f08..7969f6e1a2 100644
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -1,6 +1,8 @@
module HaddockUtils where
+import GhcPrelude
+
import HsSyn
import SrcLoc
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 936948b40f..bceb48bf48 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,6 +68,7 @@ module Lexer (
explicitNamespacesEnabled,
patternSynonymsEnabled,
sccProfilingOn, hpcEnabled,
+ starIsTypeEnabled,
addWarning,
lexTokenStream,
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -75,11 +76,11 @@ module Lexer (
moveAnnotations
) where
+import GhcPrelude
+
-- base
import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
-import Control.Monad.Fail
-#endif
+import Control.Monad.Fail as MonadFail
import Data.Bits
import Data.Char
import Data.List
@@ -105,7 +106,7 @@ import Outputable
import StringBuffer
import FastString
import UniqFM
-import Util ( readRational )
+import Util ( readRational, readHexRational )
-- compiler/main
import ErrUtils
@@ -129,38 +130,38 @@ import ApiAnnotation
-- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs
-- Any changes here should likely be reflected there.
-$unispace = \x05 -- Trick Alex into handling Unicode. See alexGetByte.
+$unispace = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$nl = [\n\r\f]
$whitechar = [$nl\v\ $unispace]
$white_no_nl = $whitechar # \n -- TODO #8424
$tab = \t
$ascdigit = 0-9
-$unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetByte.
+$unidigit = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$decdigit = $ascdigit -- for now, should really be $digit (ToDo)
$digit = [$ascdigit $unidigit]
$special = [\(\)\,\;\[\]\`\{\}]
$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
-$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte.
+$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$symbol = [$ascsymbol $unisymbol] # [$special \_\"\']
-$unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetByte.
+$unilarge = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$asclarge = [A-Z]
$large = [$asclarge $unilarge]
-$unismall = \x02 -- Trick Alex into handling Unicode. See alexGetByte.
+$unismall = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$ascsmall = [a-z]
$small = [$ascsmall $unismall \_]
-$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte.
+$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$graphic = [$small $large $symbol $digit $special $unigraphic \"\']
$binit = 0-1
$octit = 0-7
$hexit = [$decdigit A-F a-f]
-$uniidchar = \x07 -- Trick Alex into handling Unicode. See alexGetByte.
+$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex].
$idchar = [$small $large $digit $uniidchar \']
$pragmachar = [$small $large $digit]
@@ -177,11 +178,14 @@ $docsym = [\| \^ \* \$]
@varsym = ($symbol # \:) $symbol* -- variable (operator) symbol
@consym = \: $symbol* -- constructor (operator) symbol
-@decimal = $decdigit+
-@binary = $binit+
-@octal = $octit+
-@hexadecimal = $hexit+
-@exponent = [eE] [\-\+]? @decimal
+-- See Note [Lexing NumericUnderscores extension] and #14473
+@numspc = _* -- numeric spacer (#14473)
+@decimal = $decdigit(@numspc $decdigit)*
+@binary = $binit(@numspc $binit)*
+@octal = $octit(@numspc $octit)*
+@hexadecimal = $hexit(@numspc $hexit)*
+@exponent = @numspc [eE] [\-\+]? @decimal
+@bin_exponent = @numspc [pP] [\-\+]? @decimal
@qual = (@conid \.)+
@qvarid = @qual @varid
@@ -189,7 +193,8 @@ $docsym = [\| \^ \* \$]
@qvarsym = @qual @varsym
@qconsym = @qual @consym
-@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent
+@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent
-- normal signed numerical literals can only be explicitly negative,
-- not explicitly positive (contrast @exponent)
@@ -307,15 +312,18 @@ $tab { warnTab }
-- single-line line pragmas, of the form
-- # <line> "<file>" <extra-stuff> \n
-<line_prag1> @decimal { setLine line_prag1a }
-<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b }
-<line_prag1b> .* { pop }
+<line_prag1> {
+ @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag1a }
+ () { failLinePrag1 }
+}
+<line_prag1a> .* { popLinePrag1 }
-- Haskell-style line pragmas, of the form
-- {-# LINE <line> "<file>" #-}
-<line_prag2> @decimal { setLine line_prag2a }
-<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b }
-<line_prag2b> "#-}"|"-}" { pop }
+<line_prag2> {
+ @decimal $white_no_nl+ \" [$graphic \ ]* \" { setLineAndFile line_prag2a }
+}
+<line_prag2a> "#-}"|"-}" { pop }
-- NOTE: accept -} at the end of a LINE pragma, for compatibility
-- with older versions of GHC which generated these.
@@ -367,11 +375,6 @@ $tab { warnTab }
-- "special" symbols
<0> {
- "[:" / { ifExtension parrEnabled } { token ITopabrack }
- ":]" / { ifExtension parrEnabled } { token ITcpabrack }
-}
-
-<0> {
"[|" / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE
NormalSyntax) }
"[||" / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
@@ -483,21 +486,34 @@ $tab { warnTab }
-- For the normal boxed literals we need to be careful
-- when trying to be close to Haskell98
+
+-- Note [Lexing NumericUnderscores extension] (#14473)
+--
+-- NumericUnderscores extension allows underscores in numeric literals.
+-- Multiple underscores are represented with @numspc macro.
+-- To be simpler, we have only the definitions with underscores.
+-- And then we have a separate function (tok_integral and tok_frac)
+-- that validates the literals.
+-- If extensions are not enabled, check that there are no underscores.
+--
<0> {
-- Normal integral literals (:: Num a => a, from Integer)
@decimal { tok_num positive 0 0 decimal }
- 0[bB] @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary }
- 0[oO] @octal { tok_num positive 2 2 octal }
- 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
+ 0[bB] @numspc @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary }
+ 0[oO] @numspc @octal { tok_num positive 2 2 octal }
+ 0[xX] @numspc @hexadecimal { tok_num positive 2 2 hexadecimal }
@negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal }
- @negative 0[bB] @binary / { ifExtension negativeLiteralsEnabled `alexAndPred`
- ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary }
- @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
- @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
+ @negative 0[bB] @numspc @binary / { ifExtension negativeLiteralsEnabled `alexAndPred`
+ ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary }
+ @negative 0[oO] @numspc @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
+ @negative 0[xX] @numspc @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
-- Normal rational literals (:: Fractional a => a, from Rational)
- @floating_point { strtoken tok_float }
- @negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float }
+ @floating_point { tok_frac 0 tok_float }
+ @negative @floating_point / { ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_float }
+ 0[xX] @numspc @hex_floating_point / { ifExtension hexFloatLiteralsEnabled } { tok_frac 0 tok_hex_float }
+ @negative 0[xX] @numspc @hex_floating_point / { ifExtension hexFloatLiteralsEnabled `alexAndPred`
+ ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_hex_float }
}
<0> {
@@ -505,26 +521,26 @@ $tab { warnTab }
-- It's simpler (and faster?) to give separate cases to the negatives,
-- especially considering octal/hexadecimal prefixes.
@decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
- 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred`
+ 0[bB] @numspc @binary \# / { ifExtension magicHashEnabled `alexAndPred`
ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary }
- 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
- 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
+ 0[oO] @numspc @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
+ 0[xX] @numspc @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
@negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
- @negative 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred`
- ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
- @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
- @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
+ @negative 0[bB] @numspc @binary \# / { ifExtension magicHashEnabled `alexAndPred`
+ ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
+ @negative 0[oO] @numspc @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
+ @negative 0[xX] @numspc @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
@decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
- 0[bB] @binary \# \# / { ifExtension magicHashEnabled `alexAndPred`
+ 0[bB] @numspc @binary \# \# / { ifExtension magicHashEnabled `alexAndPred`
ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary }
- 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
- 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
+ 0[oO] @numspc @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
+ 0[xX] @numspc @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
-- Unboxed floats and doubles (:: Float#, :: Double#)
-- prim_{float,double} work with signed literals
- @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
- @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
+ @signed @floating_point \# / { ifExtension magicHashEnabled } { tok_frac 1 tok_primfloat }
+ @signed @floating_point \# \# / { ifExtension magicHashEnabled } { tok_frac 2 tok_primdouble }
}
-- Strings and chars are lexed by hand-written code. The reason is
@@ -620,6 +636,7 @@ data Token
| ITstatic
| ITstock
| ITanyclass
+ | ITvia
-- Backpack tokens
| ITunit
@@ -635,7 +652,8 @@ data Token
| ITrules_prag SourceText
| ITwarning_prag SourceText
| ITdeprecated_prag SourceText
- | ITline_prag
+ | ITline_prag SourceText -- not usually produced, see 'use_pos_prags'
+ | ITcolumn_prag SourceText -- not usually produced, see 'use_pos_prags'
| ITscc_prag SourceText
| ITgenerated_prag SourceText
| ITcore_prag SourceText -- hdaume: core annotations
@@ -647,15 +665,13 @@ data Token
| IToptions_prag String
| ITinclude_prag String
| ITlanguage_prag
- | ITvect_prag SourceText
- | ITvect_scalar_prag SourceText
- | ITnovect_prag SourceText
| ITminimal_prag SourceText
| IToverlappable_prag SourceText -- instance overlap mode
| IToverlapping_prag SourceText -- instance overlap mode
| IToverlaps_prag SourceText -- instance overlap mode
| ITincoherent_prag SourceText -- instance overlap mode
| ITctype SourceText
+ | ITcomment_line_prag -- See Note [Nested comment line pragmas]
| ITdotdot -- reserved symbols
| ITcolon
@@ -668,10 +684,10 @@ data Token
| ITrarrow IsUnicodeSyntax
| ITat
| ITtilde
- | ITtildehsh
| ITdarrow IsUnicodeSyntax
| ITminus
| ITbang
+ | ITstar IsUnicodeSyntax
| ITdot
| ITbiglam -- GHC-extension symbols
@@ -820,6 +836,7 @@ reservedWordsFM = listToUFM $
( "static", ITstatic, 0 ),
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
+ ( "via", ITvia, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
@@ -878,11 +895,12 @@ reservedSymsFM = listToUFM $
,("->", ITrarrow NormalSyntax, always)
,("@", ITat, always)
,("~", ITtilde, always)
- ,("~#", ITtildehsh, magicHashEnabled)
,("=>", ITdarrow NormalSyntax, always)
,("-", ITminus, always)
,("!", ITbang, always)
+ ,("*", ITstar NormalSyntax, starIsTypeEnabled)
+
-- For 'forall a . t'
,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i)
@@ -905,6 +923,8 @@ reservedSymsFM = listToUFM $
\i -> unicodeSyntaxEnabled i && arrowsEnabled i)
,("⤜", ITRarrowtail UnicodeSyntax,
\i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+ ,("★", ITstar UnicodeSyntax,
+ \i -> unicodeSyntaxEnabled i && starIsTypeEnabled i)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
@@ -938,17 +958,26 @@ strtoken :: (String -> Token) -> Action
strtoken f span buf len =
return (L span $! (f $! lexemeToString buf len))
-init_strtoken :: Int -> (String -> Token) -> Action
--- like strtoken, but drops the last N character(s)
-init_strtoken drop f span buf len =
- return (L span $! (f $! lexemeToString buf (len-drop)))
-
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
pop :: Action
pop _span _buf _len = do _ <- popLexState
lexToken
+-- See Note [Nested comment line pragmas]
+failLinePrag1 :: Action
+failLinePrag1 span _buf _len = do
+ b <- extension inNestedComment
+ if b then return (L span ITcomment_line_prag)
+ else lexError "lexical error in pragma"
+
+-- See Note [Nested comment line pragmas]
+popLinePrag1 :: Action
+popLinePrag1 span _buf _len = do
+ b <- extension inNestedComment
+ if b then return (L span ITcomment_line_prag) else do
+ _ <- popLexState
+ lexToken
hopefully_open_brace :: Action
hopefully_open_brace span buf len
@@ -1088,6 +1117,12 @@ nested_comment cont span buf len = do
Nothing -> errBrace input span
Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
Just (_,_) -> go ('\123':commentAcc) n input
+ -- See Note [Nested comment line pragmas]
+ Just ('\n',input) -> case alexGetChar' input of
+ Nothing -> errBrace input span
+ Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
+ go (parsedAcc ++ '\n':commentAcc) n input
+ Just (_,_) -> go ('\n':commentAcc) n input
Just (c,input) -> go (c:commentAcc) n input
nested_doc_comment :: Action
@@ -1107,8 +1142,60 @@ nested_doc_comment span buf _len = withLexedDocType (go "")
let cont = do input <- getInput; go commentAcc input docType False
nested_comment cont span buf _len
Just (_,_) -> go ('\123':commentAcc) input docType False
+ -- See Note [Nested comment line pragmas]
+ Just ('\n',input) -> case alexGetChar' input of
+ Nothing -> errBrace input span
+ Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
+ go (parsedAcc ++ '\n':commentAcc) input docType False
+ Just (_,_) -> go ('\n':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
+-- See Note [Nested comment line pragmas]
+parseNestedPragma :: AlexInput -> P (String,AlexInput)
+parseNestedPragma input@(AI _ buf) = do
+ origInput <- getInput
+ setInput input
+ setExts (.|. xbit InNestedCommentBit)
+ pushLexState bol
+ lt <- lexToken
+ _ <- popLexState
+ setExts (.&. complement (xbit InNestedCommentBit))
+ postInput@(AI _ postBuf) <- getInput
+ setInput origInput
+ case unLoc lt of
+ ITcomment_line_prag -> do
+ let bytes = byteDiff buf postBuf
+ diff = lexemeToString buf bytes
+ return (reverse diff, postInput)
+ lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))
+
+{-
+Note [Nested comment line pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to ignore cpp-preprocessor-generated #line pragmas if they were inside
+nested comments.
+
+Now, when parsing a nested comment, if we encounter a line starting with '#' we
+call parseNestedPragma, which executes the following:
+1. Save the current lexer input (loc, buf) for later
+2. Set the current lexer input to the beginning of the line starting with '#'
+3. Turn the 'InNestedComment' extension on
+4. Push the 'bol' lexer state
+5. Lex a token. Due to (2), (3), and (4), this should always lex a single line
+ or less and return the ITcomment_line_prag token. This may set source line
+ and file location if a #line pragma is successfully parsed
+6. Restore lexer input and state to what they were before we did all this
+7. Return control to the function parsing a nested comment, informing it of
+ what the lexer parsed
+
+Regarding (5) above:
+Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)
+checks if the 'InNestedComment' extension is set. If it is, that function will
+return control to parseNestedPragma by returning the ITcomment_line_prag token.
+
+See #314 for more background on the bug this fixes.
+-}
+
withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
-> P (RealLocated Token)
withLexedDocType lexDocComment = do
@@ -1135,6 +1222,27 @@ rulePrag span buf len = do
let !src = lexemeToString buf len
return (L span (ITrules_prag (SourceText src)))
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
+-- of updating the position in 'PState'
+linePrag :: Action
+linePrag span buf len = do
+ ps <- getPState
+ if use_pos_prags ps
+ then begin line_prag2 span buf len
+ else let !src = lexemeToString buf len
+ in return (L span (ITline_prag (SourceText src)))
+
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
+-- of updating the position in 'PState'
+columnPrag :: Action
+columnPrag span buf len = do
+ ps <- getPState
+ let !src = lexemeToString buf len
+ if use_pos_prags ps
+ then begin column_prag span buf len
+ else let !src = lexemeToString buf len
+ in return (L span (ITcolumn_prag (SourceText src)))
+
endPrag :: Action
endPrag span _buf _len = do
setExts (.&. complement (xbit InRulePragBit))
@@ -1210,15 +1318,14 @@ varid :: Action
varid span buf len =
case lookupUFM reservedWordsFM fs of
Just (ITcase, _) -> do
- lambdaCase <- extension lambdaCaseEnabled
- keyword <- if lambdaCase
- then do
- lastTk <- getLastTk
- return $ case lastTk of
- Just ITlam -> ITlcase
- _ -> ITcase
- else
- return ITcase
+ lastTk <- getLastTk
+ keyword <- case lastTk of
+ Just ITlam -> do
+ lambdaCase <- extension lambdaCaseEnabled
+ if lambdaCase
+ then return ITlcase
+ else failMsgP "Illegal lambda-case (use -XLambdaCase)"
+ _ -> return ITcase
maybe_layout keyword
return $ L span keyword
Just (ITstatic, _) -> do
@@ -1272,8 +1379,12 @@ tok_integral :: (SourceText -> Integer -> Token)
-> Int -> Int
-> (Integer, (Char -> Int))
-> Action
-tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
- = return $ L span $ itint (SourceText $ lexemeToString buf len)
+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do
+ numericUnderscores <- extension numericUnderscoresEnabled -- #14473
+ let src = lexemeToString buf len
+ if (not numericUnderscores) && ('_' `elem` src)
+ then failMsgP "Use NumericUnderscores to allow underscores in integer literals"
+ else return $ L span $ itint (SourceText src)
$! transint $ parseUnsignedInteger
(offsetBytes transbuf buf) (subtract translen len) radix char_to_int
@@ -1305,15 +1416,32 @@ octal = (8,octDecDigit)
hexadecimal = (16,hexDigit)
-- readRational can understand negative rationals, exponents, everything.
+tok_frac :: Int -> (String -> Token) -> Action
+tok_frac drop f span buf len = do
+ numericUnderscores <- extension numericUnderscoresEnabled -- #14473
+ let src = lexemeToString buf (len-drop)
+ if (not numericUnderscores) && ('_' `elem` src)
+ then failMsgP "Use NumericUnderscores to allow underscores in floating literals"
+ else return (L span $! (f $! src))
+
tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float str = ITrational $! readFractionalLit str
-tok_primfloat str = ITprimfloat $! readFractionalLit str
-tok_primdouble str = ITprimdouble $! readFractionalLit str
+tok_float str = ITrational $! readFractionalLit str
+tok_hex_float str = ITrational $! readHexFractionalLit str
+tok_primfloat str = ITprimfloat $! readFractionalLit str
+tok_primdouble str = ITprimdouble $! readFractionalLit str
readFractionalLit :: String -> FractionalLit
readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
where is_neg = case str of ('-':_) -> True
_ -> False
+readHexFractionalLit :: String -> FractionalLit
+readHexFractionalLit str =
+ FL { fl_text = SourceText str
+ , fl_neg = case str of
+ '-' : _ -> True
+ _ -> False
+ , fl_value = readHexRational str
+ }
-- -----------------------------------------------------------------------------
-- Layout processing
@@ -1321,20 +1449,23 @@ readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
-- we're at the first token on a line, insert layout tokens if necessary
do_bol :: Action
do_bol span _str _len = do
- (pos, gen_semic) <- getOffside
- case pos of
- LT -> do
- --trace "layout: inserting '}'" $ do
- popContext
- -- do NOT pop the lex state, we might have a ';' to insert
- return (L span ITvccurly)
- EQ | gen_semic -> do
- --trace "layout: inserting ';'" $ do
- _ <- popLexState
- return (L span ITsemi)
- _ -> do
- _ <- popLexState
- lexToken
+ -- See Note [Nested comment line pragmas]
+ b <- extension inNestedComment
+ if b then return (L span ITcomment_line_prag) else do
+ (pos, gen_semic) <- getOffside
+ case pos of
+ LT -> do
+ --trace "layout: inserting '}'" $ do
+ popContext
+ -- do NOT pop the lex state, we might have a ';' to insert
+ return (L span ITvccurly)
+ EQ | gen_semic -> do
+ --trace "layout: inserting ';'" $ do
+ _ <- popLexState
+ return (L span ITsemi)
+ _ -> do
+ _ <- popLexState
+ lexToken
-- certain keywords put us in the "layout" state, where we might
-- add an opening curly brace.
@@ -1394,29 +1525,13 @@ do_layout_left span _buf _len = do
-- -----------------------------------------------------------------------------
-- LINE pragmas
-setLine :: Int -> Action
-setLine code span buf len = do
- let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
- -- subtract one: the line number refers to the *following* line
- _ <- popLexState
- pushLexState code
- lexToken
-
-setColumn :: Action
-setColumn span buf len = do
- let column =
- case reads (lexemeToString buf len) of
- [(column, _)] -> column
- _ -> error "setColumn: expected integer" -- shouldn't happen
- setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)
- (fromIntegral (column :: Integer)))
- _ <- popLexState
- lexToken
-
-setFile :: Int -> Action
-setFile code span buf len = do
- let file = mkFastString (go (lexemeToString (stepOn buf) (len-2)))
+setLineAndFile :: Int -> Action
+setLineAndFile code span buf len = do
+ let src = lexemeToString buf (len - 1) -- drop trailing quotation mark
+ linenumLen = length $ head $ words src
+ linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit
+ file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src
+ -- skip everything through first quotation mark to get to the filename
where go ('\\':c:cs) = c : go cs
go (c:cs) = c : go cs
go [] = []
@@ -1430,12 +1545,24 @@ setFile code span buf len = do
-- filenames and it does not remove duplicate
-- backslashes after the drive letter (should it?).
setAlrLastLoc $ alrInitialLoc file
- setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))
+ -- subtract one: the line number refers to the *following* line
addSrcFile file
_ <- popLexState
pushLexState code
lexToken
+setColumn :: Action
+setColumn span buf len = do
+ let column =
+ case reads (lexemeToString buf len) of
+ [(column, _)] -> column
+ _ -> error "setColumn: expected integer" -- shouldn't happen
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)
+ (fromIntegral (column :: Integer)))
+ _ <- popLexState
+ lexToken
+
alrInitialLoc :: FastString -> RealSrcSpan
alrInitialLoc file = mkRealSrcSpan loc loc
where -- This is a hack to ensure that the first line in a file
@@ -1859,6 +1986,10 @@ data PState = PState {
-- token doesn't need to close anything:
alr_justClosedExplicitLetBlock :: Bool,
+ -- If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
+ -- update the 'loc' field. Otherwise, those pragmas are lexed as tokens.
+ use_pos_prags :: Bool,
+
-- The next three are used to implement Annotations giving the
-- locations of 'noise' tokens in the source, so that users of
-- the GHC API can do source to source conversions.
@@ -1892,12 +2023,10 @@ instance Applicative P where
instance Monad P where
(>>=) = thenP
- fail = failP
+ fail = MonadFail.fail
-#if __GLASGOW_HASKELL__ > 710
instance MonadFail P where
fail = failP
-#endif
returnP :: a -> P a
returnP a = a `seq` (P $ \s -> POk s a)
@@ -1970,27 +2099,29 @@ getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
data AlexInput = AI RealSrcLoc StringBuffer
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI _ buf) = prevChar buf '\n'
+{-
+Note [Unicode in Alex]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Although newer versions of Alex support unicode, this grammar is processed with
+the old style '--latin1' behaviour. This means that when implementing the
+functions
--- backwards compatibility for Alex 2.x
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar inp = case alexGetByte inp of
- Nothing -> Nothing
- Just (b,i) -> c `seq` Just (c,i)
- where c = chr $ fromIntegral b
+ alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+ alexInputPrevChar :: AlexInput -> Char
-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
-alexGetByte (AI loc s)
- | atEnd s = Nothing
- | otherwise = byte `seq` loc' `seq` s' `seq`
- --trace (show (ord c)) $
- Just (byte, (AI loc' s'))
- where (c,s') = nextChar s
- loc' = advanceSrcLoc loc c
- byte = fromIntegral $ ord adj_c
+which Alex uses to take apart our 'AlexInput', we must
- non_graphic = '\x00'
+ * return a latin1 character in the 'Word8' that 'alexGetByte' expects
+ * return a latin1 character in 'alexInputPrevChar'.
+
+We handle this in 'adjustChar' by squishing entire classes of unicode
+characters into single bytes.
+-}
+
+{-# INLINE adjustChar #-}
+adjustChar :: Char -> Word8
+adjustChar c = fromIntegral $ ord adj_c
+ where non_graphic = '\x00'
upper = '\x01'
lower = '\x02'
digit = '\x03'
@@ -2036,6 +2167,32 @@ alexGetByte (AI loc s)
Space -> space
_other -> non_graphic
+-- Getting the previous 'Char' isn't enough here - we need to convert it into
+-- the same format that 'alexGetByte' would have produced.
+--
+-- See Note [Unicode in Alex] and #13986.
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))
+ where pc = prevChar buf '\n'
+
+-- backwards compatibility for Alex 2.x
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar inp = case alexGetByte inp of
+ Nothing -> Nothing
+ Just (b,i) -> c `seq` Just (c,i)
+ where c = chr $ fromIntegral b
+
+-- See Note [Unicode in Alex]
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (AI loc s)
+ | atEnd s = Nothing
+ | otherwise = byte `seq` loc' `seq` s' `seq`
+ --trace (show (ord c)) $
+ Just (byte, (AI loc' s'))
+ where (c,s') = nextChar s
+ loc' = advanceSrcLoc loc c
+ byte = adjustChar c
+
-- This version does not squash unicode characters, it is used when
-- lexing strings.
alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
@@ -2146,7 +2303,6 @@ data ExtBits
= FfiBit
| InterruptibleFfiBit
| CApiFfiBit
- | ParrBit
| ArrowsBit
| ThBit
| ThQuotesBit
@@ -2166,6 +2322,7 @@ data ExtBits
| TransformComprehensionsBit
| QqBit -- enable quasiquoting
| InRulePragBit
+ | InNestedCommentBit -- See Note [Nested comment line pragmas]
| RawTokenStreamBit -- producing a token stream with all comments included
| SccProfilingOnBit
| HpcBit
@@ -2178,15 +2335,16 @@ data ExtBits
| LambdaCaseBit
| BinaryLiteralsBit
| NegativeLiteralsBit
+ | HexFloatLiteralsBit
| TypeApplicationsBit
| StaticPointersBit
+ | NumericUnderscoresBit
+ | StarIsTypeBit
deriving Enum
always :: ExtsBitmap -> Bool
always _ = True
-parrEnabled :: ExtsBitmap -> Bool
-parrEnabled = xtest ParrBit
arrowsEnabled :: ExtsBitmap -> Bool
arrowsEnabled = xtest ArrowsBit
thEnabled :: ExtsBitmap -> Bool
@@ -2217,6 +2375,8 @@ qqEnabled :: ExtsBitmap -> Bool
qqEnabled = xtest QqBit
inRulePrag :: ExtsBitmap -> Bool
inRulePrag = xtest InRulePragBit
+inNestedComment :: ExtsBitmap -> Bool
+inNestedComment = xtest InNestedCommentBit
rawTokenStreamEnabled :: ExtsBitmap -> Bool
rawTokenStreamEnabled = xtest RawTokenStreamBit
alternativeLayoutRule :: ExtsBitmap -> Bool
@@ -2240,12 +2400,18 @@ binaryLiteralsEnabled :: ExtsBitmap -> Bool
binaryLiteralsEnabled = xtest BinaryLiteralsBit
negativeLiteralsEnabled :: ExtsBitmap -> Bool
negativeLiteralsEnabled = xtest NegativeLiteralsBit
+hexFloatLiteralsEnabled :: ExtsBitmap -> Bool
+hexFloatLiteralsEnabled = xtest HexFloatLiteralsBit
patternSynonymsEnabled :: ExtsBitmap -> Bool
patternSynonymsEnabled = xtest PatternSynonymsBit
typeApplicationEnabled :: ExtsBitmap -> Bool
typeApplicationEnabled = xtest TypeApplicationsBit
staticPointersEnabled :: ExtsBitmap -> Bool
staticPointersEnabled = xtest StaticPointersBit
+numericUnderscoresEnabled :: ExtsBitmap -> Bool
+numericUnderscoresEnabled = xtest NumericUnderscoresBit
+starIsTypeEnabled :: ExtsBitmap -> Bool
+starIsTypeEnabled = xtest StarIsTypeBit
-- PState for parsing options pragmas
--
@@ -2264,46 +2430,55 @@ mkParserFlags flags =
, pExtsBitmap = bitmap
}
where
- bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags
- .|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags
- .|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags
- .|. ParrBit `setBitIf` xopt LangExt.ParallelArrays flags
- .|. ArrowsBit `setBitIf` xopt LangExt.Arrows flags
- .|. ThBit `setBitIf` xopt LangExt.TemplateHaskell flags
- .|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags
- .|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags
- .|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags
- .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags
- .|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags
- .|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags
- .|. HaddockBit `setBitIf` gopt Opt_Haddock flags
- .|. MagicHashBit `setBitIf` xopt LangExt.MagicHash flags
- .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags
- .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags
- .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags
- .|. UnboxedSumsBit `setBitIf` xopt LangExt.UnboxedSums flags
- .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags
- .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags
- .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags
- .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags
- .|. HpcBit `setBitIf` gopt Opt_Hpc flags
- .|. AlternativeLayoutRuleBit `setBitIf` xopt LangExt.AlternativeLayoutRule flags
- .|. RelaxedLayoutBit `setBitIf` xopt LangExt.RelaxedLayout flags
- .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags
- .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
- .|. SafeHaskellBit `setBitIf` safeImportsOn flags
- .|. TraditionalRecordSyntaxBit `setBitIf` xopt LangExt.TraditionalRecordSyntax flags
- .|. ExplicitNamespacesBit `setBitIf` xopt LangExt.ExplicitNamespaces flags
- .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags
- .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags
- .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags
- .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags
- .|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags
- .|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags
-
- setBitIf :: ExtBits -> Bool -> ExtsBitmap
- b `setBitIf` cond | cond = xbit b
- | otherwise = 0
+ bitmap = safeHaskellBit .|. langExtBits .|. optBits
+ safeHaskellBit =
+ SafeHaskellBit `setBitIf` safeImportsOn flags
+ langExtBits =
+ FfiBit `xoptBit` LangExt.ForeignFunctionInterface
+ .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI
+ .|. CApiFfiBit `xoptBit` LangExt.CApiFFI
+ .|. ArrowsBit `xoptBit` LangExt.Arrows
+ .|. ThBit `xoptBit` LangExt.TemplateHaskell
+ .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes
+ .|. QqBit `xoptBit` LangExt.QuasiQuotes
+ .|. IpBit `xoptBit` LangExt.ImplicitParams
+ .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels
+ .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll
+ .|. BangPatBit `xoptBit` LangExt.BangPatterns
+ .|. MagicHashBit `xoptBit` LangExt.MagicHash
+ .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo
+ .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax
+ .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples
+ .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums
+ .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts
+ .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp
+ .|. TransformComprehensionsBit `xoptBit` LangExt.MonadComprehensions
+ .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule
+ .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout
+ .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
+ .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax
+ .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces
+ .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase
+ .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals
+ .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals
+ .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals
+ .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms
+ .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications
+ .|. StaticPointersBit `xoptBit` LangExt.StaticPointers
+ .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores
+ .|. StarIsTypeBit `xoptBit` LangExt.StarIsType
+ optBits =
+ HaddockBit `goptBit` Opt_Haddock
+ .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream
+ .|. HpcBit `goptBit` Opt_Hpc
+ .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn
+
+ xoptBit bit ext = bit `setBitIf` xopt ext flags
+ goptBit bit opt = bit `setBitIf` gopt opt flags
+
+ setBitIf :: ExtBits -> Bool -> ExtsBitmap
+ b `setBitIf` cond | cond = xbit b
+ | otherwise = 0
-- | Creates a parse state from a 'DynFlags' value
mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
@@ -2331,6 +2506,7 @@ mkPStatePure options buf loc =
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
+ use_pos_prags = True,
annotations = [],
comment_q = [],
annotations_comments = []
@@ -2742,14 +2918,14 @@ reportLexError loc1 loc2 buf str
lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
- initState = mkPState dflags' buf loc
+ initState = (mkPState dflags' buf loc) { use_pos_prags = False }
go = do
ltok <- lexer False return
case ltok of
L _ ITeof -> return []
_ -> liftM (ltok:) go
-linePrags = Map.singleton "line" (begin line_prag2)
+linePrags = Map.singleton "line" linePrag
fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
("options_ghc", lex_string_prag IToptions_prag),
@@ -2785,8 +2961,6 @@ oneWordPrags = Map.fromList [
("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
("ann", strtoken (\s -> ITann_prag (SourceText s))),
- ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))),
- ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))),
("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
@@ -2794,10 +2968,10 @@ oneWordPrags = Map.fromList [
("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
("ctype", strtoken (\s -> ITctype (SourceText s))),
("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
- ("column", begin column_prag)
+ ("column", columnPrag)
]
-twoWordPrags = Map.fromList([
+twoWordPrags = Map.fromList [
("inline conlike",
strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
("notinline conlike",
@@ -2805,9 +2979,8 @@ twoWordPrags = Map.fromList([
("specialize inline",
strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
("specialize notinline",
- strtoken (\s -> (ITspec_inline_prag (SourceText s) False))),
- ("vectorize scalar",
- strtoken (\s -> ITvect_scalar_prag (SourceText s)))])
+ strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
+ ]
dispatch_pragmas :: Map String Action -> Action
dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
@@ -2829,8 +3002,6 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
canonical prag' = case prag' of
"noinline" -> "notinline"
"specialise" -> "specialize"
- "vectorise" -> "vectorize"
- "novectorise" -> "novectorize"
"constructorlike" -> "conlike"
_ -> prag'
canon_ws s = unwords (map canonical (words s))
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 672b6f74ab..dd9beadc4d 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -48,7 +48,7 @@ import PackageConfig
import OrdList
import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue )
import FastString
-import Maybes ( orElse )
+import Maybes ( isJust, orElse )
import Outputable
-- compiler/basicTypes
@@ -76,21 +76,20 @@ import TcEvidence ( emptyTcEvBinds )
-- compiler/prelude
import ForeignCall
import TysPrim ( eqPrimTyCon )
-import PrelNames ( eqTyCon_RDR )
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
unboxedUnitTyCon, unboxedUnitDataCon,
- listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
+ listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
-- compiler/utils
import Util ( looksLikePackageName )
-import Prelude
+import GhcPrelude
import qualified GHC.LanguageExtensions as LangExt
}
-%expect 36 -- shift/reduce conflicts
+%expect 235 -- shift/reduce conflicts
-{- Last updated: 3 Aug 2016
+{- Last updated: 04 June 2018
If you modify this parser and add a conflict, please update this comment.
You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -121,7 +120,7 @@ follows. Shift parses as if the 'module' keyword follows.
-------------------------------------------------------------------------------
-state 48 contains 2 shift/reduce conflicts.
+state 57 contains 2 shift/reduce conflicts.
*** strict_mark -> unpackedness .
strict_mark -> unpackedness . strictness
@@ -130,7 +129,7 @@ state 48 contains 2 shift/reduce conflicts.
-------------------------------------------------------------------------------
-state 52 contains 1 shift/reduce conflict.
+state 61 contains 1 shift/reduce conflict.
context -> btype .
*** type -> btype .
@@ -140,16 +139,25 @@ state 52 contains 1 shift/reduce conflict.
-------------------------------------------------------------------------------
-state 53 contains 9 shift/reduce conflicts.
+state 62 contains 46 shift/reduce conflicts.
*** btype -> tyapps .
tyapps -> tyapps . tyapp
- Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+ Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE
+ VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM
+ STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE
+ and all the special ids.
+
+Example ambiguity:
+ 'if x then y else z :: F a'
+
+Shift parses as (per longest-parse rule):
+ 'if x then y else z :: (F a)'
-------------------------------------------------------------------------------
-state 134 contains 14 shift/reduce conflicts.
+state 144 contains 15 shift/reduce conflicts.
exp -> infixexp . '::' sigtype
exp -> infixexp . '-<' exp
@@ -160,7 +168,7 @@ state 134 contains 14 shift/reduce conflicts.
infixexp -> infixexp . qop exp10
Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'
- '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+ '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM
Examples of ambiguity:
'if x then y else z -< e'
@@ -174,7 +182,44 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 299 contains 1 shift/reduce conflicts.
+state 149 contains 67 shift/reduce conflicts.
+
+ *** exp10 -> fexp .
+ fexp -> fexp . aexp
+ fexp -> fexp . TYPEAPP atype
+
+ Conflicts: TYPEAPP and all the tokens that can start an aexp
+
+Examples of ambiguity:
+ 'if x then y else f z'
+ 'if x then y else f @ z'
+
+Shift parses as (per longest-parse rule):
+ 'if x then y else (f z)'
+ 'if x then y else (f @ z)'
+
+-------------------------------------------------------------------------------
+
+state 204 contains 27 shift/reduce conflicts.
+
+ aexp2 -> TH_TY_QUOTE . tyvar
+ aexp2 -> TH_TY_QUOTE . gtycon
+ *** aexp2 -> TH_TY_QUOTE .
+
+ Conflicts: two single quotes is error syntax with specific error message.
+
+Example of ambiguity:
+ 'x = '''
+ 'x = ''a'
+ 'x = ''T'
+
+Shift parses as (per longest-parse rule):
+ 'x = ''a'
+ 'x = ''T'
+
+-------------------------------------------------------------------------------
+
+state 300 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp
@@ -192,18 +237,18 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
-state 309 contains 1 shift/reduce conflict.
+state 310 contains 1 shift/reduce conflict.
*** type -> btype .
type -> btype . '->' ctype
Conflict: '->'
-Same as state 50 but without contexts.
+Same as state 61 but without contexts.
-------------------------------------------------------------------------------
-state 348 contains 1 shift/reduce conflicts.
+state 354 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(' commas . ')'
@@ -218,7 +263,7 @@ if -XTupleSections is not specified.
-------------------------------------------------------------------------------
-state 402 contains 1 shift/reduce conflicts.
+state 409 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(#' commas . '#)'
@@ -226,22 +271,35 @@ state 402 contains 1 shift/reduce conflicts.
Conflict: '#)' (empty tup_tail reduces)
-Same as State 324 for unboxed tuples.
+Same as State 354 for unboxed tuples.
+
+-------------------------------------------------------------------------------
+
+state 417 contains 67 shift/reduce conflicts.
+
+ *** exp10 -> '-' fexp .
+ fexp -> fexp . aexp
+ fexp -> fexp . TYPEAPP atype
+
+Same as 149 but with a unary minus.
-------------------------------------------------------------------------------
-state 477 contains 1 shift/reduce conflict.
+state 481 contains 1 shift/reduce conflict.
oqtycon -> '(' qtyconsym . ')'
*** qtyconop -> qtyconsym .
Conflict: ')'
-TODO: Why?
+Example ambiguity: 'foo :: (:%)'
+
+Shift means '(:%)' gets parsed as a type constructor, rather than than a
+parenthesized infix type expression of length 1.
-------------------------------------------------------------------------------
-state 658 contains 1 shift/reduce conflicts.
+state 675 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar .
dbind -> ipvar . '=' exp
@@ -256,7 +314,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
-state 731 contains 1 shift/reduce conflicts.
+state 752 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp
@@ -273,7 +331,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
-state 963 contains 1 shift/reduce conflicts.
+state 986 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp
transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -283,14 +341,25 @@ state 963 contains 1 shift/reduce conflicts.
-------------------------------------------------------------------------------
-state 1303 contains 1 shift/reduce conflict.
+state 1367 contains 1 shift/reduce conflict.
*** atype -> tyvar .
tv_bndr -> '(' tyvar . '::' kind ')'
Conflict: '::'
-TODO: Why?
+Example ambiguity: 'class C a where type D a = ( a :: * ...'
+
+Here the parser cannot tell whether this is specifying a default for the
+associated type like:
+
+'class C a where type D a = ( a :: * ); type D a'
+
+or it is an injectivity signature like:
+
+'class C a where type D a = ( r :: * ) | r -> a'
+
+Shift means the parser only allows the latter.
-------------------------------------------------------------------------------
-- API Annotations
@@ -414,6 +483,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'static' { L _ ITstatic } -- for static pointers extension
'stock' { L _ ITstock } -- for DerivingStrategies extension
'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
+ 'via' { L _ ITvia } -- for DerivingStrategies extension
'unit' { L _ ITunit }
'signature' { L _ ITsignature }
@@ -432,9 +502,6 @@ are the most common patterns, rewritten as regular expressions for clarity:
'{-# UNPACK' { L _ (ITunpack_prag _) }
'{-# NOUNPACK' { L _ (ITnounpack_prag _) }
'{-# ANN' { L _ (ITann_prag _) }
- '{-# VECTORISE' { L _ (ITvect_prag _) }
- '{-# VECTORISE_SCALAR' { L _ (ITvect_scalar_prag _) }
- '{-# NOVECTORISE' { L _ (ITnovect_prag _) }
'{-# MINIMAL' { L _ (ITminimal_prag _) }
'{-# CTYPE' { L _ (ITctype _) }
'{-# OVERLAPPING' { L _ (IToverlapping_prag _) }
@@ -455,10 +522,10 @@ are the most common patterns, rewritten as regular expressions for clarity:
'->' { L _ (ITrarrow _) }
'@' { L _ ITat }
'~' { L _ ITtilde }
- '~#' { L _ ITtildehsh }
'=>' { L _ (ITdarrow _) }
'-' { L _ ITminus }
'!' { L _ ITbang }
+ '*' { L _ (ITstar _) }
'-<' { L _ (ITlarrowtail _) } -- for arrow notation
'>-' { L _ (ITrarrowtail _) } -- for arrow notation
'-<<' { L _ (ITLarrowtail _) } -- for arrow notation
@@ -558,7 +625,9 @@ identifier :: { Located RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
- [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
+ [mop $1,mu AnnRarrow $2,mcp $3] }
+ | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR)
+ [mop $1,mj AnnTilde $2,mcp $3] }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -781,9 +850,9 @@ expdoclist :: { OrdList (LIE GhcPs) }
| {- empty -} { nilOL }
exp_doc :: { OrdList (LIE GhcPs) }
- : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }
- | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) }
- | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) }
+ : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExt n doc)) }
+ | docnamed { unitOL (sL1 $1 (IEDocNamed noExt ((fst . unLoc) $1))) }
+ | docnext { unitOL (sL1 $1 (IEDoc noExt (unLoc $1))) }
-- No longer allow things like [] and (,,,) to be exported
@@ -791,9 +860,9 @@ exp_doc :: { OrdList (LIE GhcPs) }
export :: { OrdList (LIE GhcPs) }
: qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2)
>>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
- | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2))
+ | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExt $2))
[mj AnnModule $1] }
- | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))
+ | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExt (sLL $1 $> (IEPattern $2))))
[mj AnnPattern $1] }
export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
@@ -870,7 +939,8 @@ importdecls_semi
importdecl :: { LImportDecl GhcPs }
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
{% ams (L (comb4 $1 $6 (snd $7) $8) $
- ImportDecl { ideclSourceSrc = snd $ fst $2
+ ImportDecl { ideclExt = noExt
+ , ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
, ideclSource = snd $2, ideclSafe = snd $3
, ideclQualified = snd $4, ideclImplicit = False
@@ -953,49 +1023,22 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) }
| {- empty -} { nilOL }
topdecl :: { LHsDecl GhcPs }
- : cl_decl { sL1 $1 (TyClD (unLoc $1)) }
- | ty_decl { sL1 $1 (TyClD (unLoc $1)) }
- | inst_decl { sL1 $1 (InstD (unLoc $1)) }
- | stand_alone_deriving { sLL $1 $> (DerivD (unLoc $1)) }
- | role_annot { sL1 $1 (RoleAnnotD (unLoc $1)) }
- | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD (DefaultDecl $3)))
+ : cl_decl { sL1 $1 (TyClD noExt (unLoc $1)) }
+ | ty_decl { sL1 $1 (TyClD noExt (unLoc $1)) }
+ | inst_decl { sL1 $1 (InstD noExt (unLoc $1)) }
+ | stand_alone_deriving { sLL $1 $> (DerivD noExt (unLoc $1)) }
+ | role_annot { sL1 $1 (RoleAnnotD noExt (unLoc $1)) }
+ | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExt (DefaultDecl noExt $3)))
[mj AnnDefault $1
,mop $2,mcp $4] }
| 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2))
(mj AnnForeign $1:(fst $ unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
+ | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs $1) (fromOL $2)))
[mo $1,mc $3] }
- | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))
+ | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getWARNING_PRAGs $1) (fromOL $2)))
[mo $1,mc $3] }
- | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))
+ | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExt (HsRules noExt (getRULES_PRAGs $1) (fromOL $2)))
[mo $1,mc $3] }
- | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))
- [mo $1,mj AnnEqual $3
- ,mc $5] }
- | '{-# NOVECTORISE' qvar '#-}' {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))
- [mo $1,mc $3] }
- | '{-# VECTORISE' 'type' gtycon '#-}'
- {% ams (sLL $1 $> $
- VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))
- [mo $1,mj AnnType $2,mc $4] }
-
- | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
- {% ams (sLL $1 $> $
- VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))
- [mo $1,mj AnnType $2,mc $4] }
-
- | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
- {% ams (sLL $1 $> $
- VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))
- [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
- | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
- {% ams (sLL $1 $> $
- VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))
- [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
-
- | '{-# VECTORISE' 'class' gtycon '#-}'
- {% ams (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))
- [mo $1,mj AnnClass $2,mc $4] }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1066,12 +1109,13 @@ ty_decl :: { LTyClDecl GhcPs }
inst_decl :: { LInstDecl GhcPs }
: 'instance' overlap_pragma inst_type where_inst
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
- ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
+ ; let cid = ClsInstDecl { cid_ext = noExt
+ , cid_poly_ty = $3, cid_binds = binds
, cid_sigs = mkClassOpSigs sigs
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid }))
+ ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1109,13 +1153,26 @@ overlap_pragma :: { Maybe (Located OverlapMode) }
[mo $1,mc $2] }
| {- empty -} { Nothing }
-deriv_strategy :: { Maybe (Located DerivStrategy) }
+deriv_strategy_no_via :: { LDerivStrategy GhcPs }
+ : 'stock' {% ams (sL1 $1 StockStrategy)
+ [mj AnnStock $1] }
+ | 'anyclass' {% ams (sL1 $1 AnyclassStrategy)
+ [mj AnnAnyclass $1] }
+ | 'newtype' {% ams (sL1 $1 NewtypeStrategy)
+ [mj AnnNewtype $1] }
+
+deriv_strategy_via :: { LDerivStrategy GhcPs }
+ : 'via' type {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))
+ [mj AnnVia $1] }
+
+deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
: 'stock' {% ajs (Just (sL1 $1 StockStrategy))
[mj AnnStock $1] }
| 'anyclass' {% ajs (Just (sL1 $1 AnyclassStrategy))
[mj AnnAnyclass $1] }
| 'newtype' {% ajs (Just (sL1 $1 NewtypeStrategy))
[mj AnnNewtype $1] }
+ | deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
-- Injective type families
@@ -1154,21 +1211,23 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% asl (unLoc $1) $2 (snd $ unLoc $3)
- >> ams $3 (fst $ unLoc $3)
- >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }
+ {% let L loc (anns, eqn) = $3 in
+ asl (unLoc $1) $2 (L loc eqn)
+ >> ams $3 anns
+ >> 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 {% ams $1 (fst $ unLoc $1)
- >> return (sLL $1 $> [snd $ unLoc $1]) }
+ | ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in
+ ams $1 anns
+ >> return (sLL $1 $> [L loc eqn]) }
| {- empty -} { noLoc [] }
-ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) }
+ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
- ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } }
+ ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
-- Associated type family declarations
--
@@ -1273,22 +1332,22 @@ opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) }
| '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) }
opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLoc NoSig )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
+ : { noLoc ([] , noLoc (NoSig noExt) )}
+ | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))}
opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLoc NoSig )}
- | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
- | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))}
+ : { noLoc ([] , noLoc (NoSig noExt) )}
+ | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))}
+ | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExt $2))}
opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs
, Maybe (LInjectivityAnn GhcPs)))}
- : { noLoc ([], (noLoc NoSig, Nothing)) }
+ : { noLoc ([], (noLoc (NoSig noExt), Nothing)) }
| '::' kind { sLL $1 $> ( [mu AnnDcolon $1]
- , (sLL $2 $> (KindSig $2), Nothing)) }
+ , (sLL $2 $> (KindSig noExt $2), Nothing)) }
| '=' tv_bndr '|' injectivity_cond
{ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]
- , (sLL $1 $2 (TyVarSig $2), Just $4))}
+ , (sLL $1 $2 (TyVarSig noExt $2), Just $4))}
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
@@ -1320,10 +1379,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl GhcPs }
- : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
+ : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+ ; ams (sLL $1 (hsSigType $>)
+ (DerivDecl noExt (mkHsWildCardBndrs $5) $2 $4))
[mj AnnDeriving $1, mj AnnInstance $3] } }
-----------------------------------------------------------------------------
@@ -1354,28 +1414,28 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 }
pattern_synonym_decl :: { LHsDecl GhcPs }
: 'pattern' pattern_synonym_lhs '=' pat
{% let (name, args,as ) = $2 in
- ams (sLL $1 $> . ValD $ mkPatSynBind name args $4
+ ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4
ImplicitBidirectional)
(as ++ [mj AnnPattern $1, mj AnnEqual $3])
}
| 'pattern' pattern_synonym_lhs '<-' pat
{% let (name, args, as) = $2 in
- ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
+ ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 Unidirectional)
(as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args, as) = $2
; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
- ; ams (sLL $1 $> . ValD $
+ ; ams (sLL $1 $> . ValD noExt $
mkPatSynBind name args $4 (ExplicitBidirectional mg))
(as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
}}
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
- : con vars0 { ($1, PrefixPatSyn $2, []) }
- | varid conop varid { ($2, InfixPatSyn $1 $3, []) }
- | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }
+ : con vars0 { ($1, PrefixCon $2, []) }
+ | varid conop varid { ($2, InfixCon $1 $3, []) }
+ | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
@@ -1395,7 +1455,7 @@ where_decls :: { Located ([AddAnn]
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtypedoc
- {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4))
+ {% ams (sLL $1 $> $ PatSynSig noExt (unLoc $2) (mkLHsSigType $4))
[mj AnnPattern $1, mu AnnDcolon $3] }
-----------------------------------------------------------------------------
@@ -1412,7 +1472,7 @@ decl_cls : at_decl_cls { $1 }
{% do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)
+ ; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4)
[mj AnnDefault $1,mu AnnDcolon $3] } }
decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1450,7 +1510,7 @@ where_cls :: { Located ([AddAnn]
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl GhcPs)) }
-decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) }
+decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExt (unLoc $1)))) }
| decl { sLL $1 $> (unitOL $1) }
decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1518,15 +1578,13 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
-- No type declarations
: decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
; return (sL1 $1 (fst $ unLoc $1
- ,sL1 $1 $ HsValBinds val_binds)) } }
+ ,sL1 $1 $ HsValBinds noExt val_binds)) } }
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
- ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
- emptyTcEvBinds)) }
+ ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
| vocurly dbinds close { L (getLoc $2) ([]
- ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
- emptyTcEvBinds)) }
+ ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
@@ -1550,10 +1608,9 @@ rules :: { OrdList (LRuleDecl GhcPs) }
rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_forall infixexp '=' exp
- {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))
+ {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1))
((snd $2) `orElse` AlwaysActive)
- (snd $3) $4 placeHolderNames $6
- placeHolderNames))
+ (snd $3) $4 $6))
(mj AnnEqual $5 : (fst $2) ++ (fst $3)) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1579,8 +1636,8 @@ rule_var_list :: { [LRuleBndr GhcPs] }
| rule_var rule_var_list { $1 : $2 }
rule_var :: { LRuleBndr GhcPs }
- : varid { sLL $1 $> (RuleBndr $1) }
- | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2
+ : varid { sLL $1 $> (RuleBndr noExt $1) }
+ | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig noExt $2
(mkLHsSigWcType $4)))
[mop $1,mu AnnDcolon $3,mcp $5] }
@@ -1598,7 +1655,7 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
+ {% amsu (sLL $1 $> (Warning noExt (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
(fst $ unLoc $2) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -1613,7 +1670,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
- {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
+ {% amsu (sLL $1 $> $ (Warning noExt (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
(fst $ unLoc $2) }
strings :: { Located ([AddAnn],[Located StringLiteral]) }
@@ -1630,17 +1687,17 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
-----------------------------------------------------------------------------
-- Annotations
annotation :: { LHsDecl GhcPs }
- : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation
+ : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
(getANN_PRAGs $1)
(ValueAnnProvenance $2) $3))
[mo $1,mc $4] }
- | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation
+ | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
(getANN_PRAGs $1)
(TypeAnnProvenance $3) $4))
[mo $1,mj AnnType $2,mc $5] }
- | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation
+ | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
(getANN_PRAGs $1)
ModuleAnnProvenance $3))
[mo $1,mj AnnModule $2,mc $4] }
@@ -1690,10 +1747,6 @@ opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
: {- empty -} { ([],Nothing) }
| '::' sigtype { ([mu AnnDcolon $1],Just $2) }
-opt_asig :: { ([AddAnn],Maybe (LHsType GhcPs)) }
- : {- empty -} { ([],Nothing) }
- | '::' atype { ([mu AnnDcolon $1],Just $2) }
-
opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
: {- empty -} { ([], Nothing) }
| '::' gtycon { ([mu AnnDcolon $1], Just $2) }
@@ -1741,13 +1794,15 @@ ctype :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
+ , hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1, mj AnnDot $3] }
| context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
+ , hst_xqual = noExt
, hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3))
+ | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
[mu AnnDcolon $2] }
| type { $1 }
@@ -1766,13 +1821,15 @@ ctypedoc :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
+ , hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1,mj AnnDot $3] }
| context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
+ , hst_xqual = noExt
, hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3))
+ | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
[mu AnnDcolon $2] }
| typedoc { $1 }
@@ -1797,7 +1854,7 @@ context :: { LHsContext GhcPs }
} }
context_no_ops :: { LHsContext GhcPs }
- : btype_no_ops {% do { ty <- splitTilde $1
+ : btype_no_ops {% do { ty <- splitTilde (reverse (unLoc $1))
; (anns,ctx) <- checkContext ty
; if null (unLoc ctx)
then addAnnotation (gl ty) AnnUnit (gl ty)
@@ -1809,9 +1866,10 @@ context_no_ops :: { LHsContext GhcPs }
~~~~~~~~~~~~~~~~~~~~~
The type production for
- btype `->` btype
+ btype `->` ctypedoc
+ btype docprev `->` ctypedoc
-adds the AnnRarrow annotation twice, in different places.
+add the AnnRarrow annotation twice, in different places.
This is because if the type is processed as usual, it belongs on the annotations
for the type as a whole.
@@ -1824,91 +1882,106 @@ is connected to the first type too.
type :: { LHsType GhcPs }
: btype { $1 }
| btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy $1 $3)
+ >> ams (sLL $1 $> $ HsFunTy noExt $1 $3)
[mu AnnRarrow $2] }
typedoc :: { LHsType GhcPs }
: btype { $1 }
- | btype docprev { sLL $1 $> $ HsDocTy $1 $2 }
- | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3)
+ | btype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 }
+ | docnext btype { sLL $1 $> $ HsDocTy noExt $2 $1 }
+ | btype '->' ctypedoc {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy noExt $1 $3)
[mu AnnRarrow $2] }
- | btype docprev '->' ctypedoc {% ams (sLL $1 $> $
- HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
+ | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $
+ HsFunTy noExt (L (comb2 $1 $2)
+ (HsDocTy noExt $1 $2))
+ $4)
+ [mu AnnRarrow $3] }
+ | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $
+ HsFunTy noExt (L (comb2 $1 $2)
+ (HsDocTy noExt $2 $1))
$4)
[mu AnnRarrow $3] }
+
+
-- See Note [Parsing ~]
btype :: { LHsType GhcPs }
- : tyapps {% splitTildeApps (reverse (unLoc $1)) >>=
- \ts -> return $ sL1 $1 $ HsAppsTy ts }
+ : tyapps {% mergeOps (unLoc $1) }
-- Used for parsing Haskell98-style data constructors,
-- in order to forbid the blasphemous
-- > data Foo = Int :+ Char :* Bool
-- See also Note [Parsing data constructors is hard] in RdrHsSyn
-btype_no_ops :: { LHsType GhcPs }
- : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 }
- | atype { $1 }
+btype_no_ops :: { Located [LHsType GhcPs] } -- NB: This list is reversed
+ : atype_docs { sL1 $1 [$1] }
+ | btype_no_ops atype_docs { sLL $1 $> $ $2 : (unLoc $1) }
-tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed
+tyapps :: { Located [Located TyEl] } -- NB: This list is reversed
: tyapp { sL1 $1 [$1] }
| tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) }
--- See Note [HsAppsTy] in HsTypes
-tyapp :: { LHsAppType GhcPs }
- : atype { sL1 $1 $ HsAppPrefix $1 }
- | qtyconop { sL1 $1 $ HsAppInfix $1 }
- | tyvarop { sL1 $1 $ HsAppInfix $1 }
- | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2)
- [mj AnnSimpleQuote $1] }
- | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2)
- [mj AnnSimpleQuote $1] }
+tyapp :: { Located TyEl }
+ : atype { sL1 $1 $ TyElOpd (unLoc $1) }
+ | 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] }
+ | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
+ [mj AnnSimpleQuote $1,mj AnnVal $2] }
+
+atype_docs :: { LHsType GhcPs }
+ : atype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 }
+ | atype { $1 }
atype :: { LHsType GhcPs }
- : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples
- | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples])
- | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
+ : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples
+ | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples])
+ | '*' {% do { warnStarIsType (getLoc $1)
+ ; return $ sL1 $1 (HsStarTy noExt (isUnicode $1)) } }
+ | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2))
(fst $ unLoc $1) } -- Constructor sigs only
| '{' fielddecls '}' {% amms (checkRecordSyntax
- (sLL $1 $> $ HsRecTy $2))
+ (sLL $1 $> $ HsRecTy noExt $2))
-- Constructor sigs only
[moc $1,mcc $3] }
- | '(' ')' {% ams (sLL $1 $> $ HsTupleTy
+ | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExt
HsBoxedOrConstraintTuple [])
[mop $1,mcp $2] }
| '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
- ams (sLL $1 $> $ HsTupleTy
+ ams (sLL $1 $> $ HsTupleTy noExt
+
HsBoxedOrConstraintTuple ($2 : $4))
[mop $1,mcp $5] }
- | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
+ | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple [])
[mo $1,mc $2] }
- | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
+ | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2)
[mo $1,mc $3] }
- | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2)
+ | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExt $2)
[mo $1,mc $3] }
- | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] }
- | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] }
- | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] }
- | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4)
+ | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy noExt $2) [mos $1,mcs $3] }
+ | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy noExt $2) [mop $1,mcp $3] }
+ | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig noExt $2 $4)
[mop $1,mu AnnDcolon $3,mcp $5] }
- | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
+ | quasiquote { sL1 $1 (HsSpliceTy noExt (unLoc $1) ) }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
- | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $
+ | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $
(sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
[mj AnnThIdSplice $1] }
-- see Note [Promotion] for the followings
- | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')'
{% addAnnotation (gl $3) AnnComma (gl $4) >>
- ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+ ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
[mj AnnSimpleQuote $1,mop $2,mcp $6] }
- | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted
- placeHolderKind $3)
+ | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3)
[mj AnnSimpleQuote $1,mos $2,mcs $4] }
- | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2)
+ | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2)
[mj AnnSimpleQuote $1,mj AnnName $2] }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
@@ -1917,13 +1990,12 @@ atype :: { LHsType GhcPs }
-- so you have to quote those.)
| '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma
(gl $3) >>
- ams (sLL $1 $> $ HsExplicitListTy NotPromoted
- placeHolderKind ($2 : $4))
+ ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4))
[mos $1,mcs $5] }
- | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
- (il_value (getINTEGER $1)) }
- | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
- (getSTRING $1) }
+ | INTEGER { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1)
+ (il_value (getINTEGER $1)) }
+ | STRING { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1)
+ (getSTRING $1) }
| '_' { sL1 $1 $ mkAnonWildCardTy }
-- An inst_type is what occurs in the head of an instance decl
@@ -1958,8 +2030,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr GhcPs }
- : tyvar { sL1 $1 (UserTyVar $1) }
- | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4))
+ : tyvar { sL1 $1 (UserTyVar noExt $1) }
+ | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExt $2 $4))
[mop $1,mu AnnDcolon $3
,mcp $5] }
@@ -1988,13 +2060,13 @@ Note [Parsing ~]
Due to parsing conflicts between laziness annotations in data type
declarations (see strict_mark) and equality types ~'s are always
-parsed as laziness annotations, and turned into HsEqTy's in the
+parsed as laziness annotations, and turned into HsOpTy's in the
correct places using RdrHsSyn.splitTilde.
Since strict_mark is parsed as part of atype which is part of type,
typedoc and context (where HsEqTy previously appeared) it made most
sense and was simplest to parse ~ as part of strict_mark and later
-turn them into HsEqTy's.
+turn them into HsOpTy's.
-}
@@ -2032,14 +2104,17 @@ both become a HsTyVar ("Zero", DataName) after the renamer.
gadt_constrlist :: { Located ([AddAnn]
,[LConDecl GhcPs]) } -- Returned in order
- : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3)
- ([mj AnnWhere $1
- ,moc $2
- ,mcc $4]
- , unLoc $3) }
- | 'where' vocurly gadt_constrs close { L (comb2 $1 $3)
- ([mj AnnWhere $1]
- , unLoc $3) }
+
+ : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
+ L (comb2 $1 $3)
+ ([mj AnnWhere $1
+ ,moc $2
+ ,mcc $4]
+ , unLoc $3) }
+ | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
+ L (comb2 $1 $3)
+ ([mj AnnWhere $1]
+ , unLoc $3) }
| {- empty -} { noLoc ([],[]) }
gadt_constrs :: { Located [LConDecl GhcPs] }
@@ -2065,9 +2140,10 @@ gadt_constr_with_doc
gadt_constr :: { LConDecl GhcPs }
-- see Note [Difference in parsing GADT and data constructors]
-- Returns a list because of: C,D :: ty
- : con_list '::' sigtype
- {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
- [mu AnnDcolon $2] }
+ : con_list '::' sigtypedoc
+ {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3
+ in ams (sLL $1 $> gadt)
+ (mu AnnDcolon $2:anns) }
{- Note [Difference in parsing GADT and data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2092,29 +2168,39 @@ constrs1 :: { Located [LConDecl GhcPs] }
| constr { sL1 $1 [$1] }
constr :: { LConDecl GhcPs }
- : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
- {% ams (let (con,details) = unLoc $5 in
+ : maybe_docnext forall context_no_ops '=>' constr_stuff
+ {% ams (let (con,details,doc_prev) = unLoc $5 in
addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
- (snd $ unLoc $2) $3 details))
- ($1 `mplus` $6))
+ (snd $ unLoc $2)
+ (Just $3)
+ details))
+ ($1 `mplus` doc_prev))
(mu AnnDarrow $4:(fst $ unLoc $2)) }
- | maybe_docnext forall constr_stuff maybe_docprev
- {% ams ( let (con,details) = unLoc $3 in
+ | maybe_docnext forall constr_stuff
+ {% ams ( let (con,details,doc_prev) = unLoc $3 in
addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
- (snd $ unLoc $2) (noLoc []) details))
- ($1 `mplus` $4))
+ (snd $ unLoc $2)
+ Nothing -- No context
+ details))
+ ($1 `mplus` doc_prev))
(fst $ unLoc $2) }
forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
+constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) }
-- See Note [Parsing data constructors is hard] in RdrHsSyn
- : btype_no_ops {% do { c <- splitCon $1
- ; return $ sLL $1 $> c } }
- | btype_no_ops conop btype_no_ops {% do { ty <- splitTilde $1
- ; return $ sLL $1 $> ($2, InfixCon ty $3) } }
+ : btype_no_ops {% do { c <- splitCon (unLoc $1)
+ ; return $ sL1 $1 c } }
+ | btype_no_ops conop maybe_docprev btype_no_ops
+ {% do { lhs <- splitTilde (reverse (unLoc $1))
+ ; (_, ds_l) <- checkInfixConstr lhs
+ ; let rhs1 = foldl1 mkHsAppTy (reverse (unLoc $4))
+ ; (rhs, ds_r) <- checkInfixConstr rhs1
+ ; return $ if isJust (ds_l `mplus` $3)
+ then sLL $1 $> ($2, InfixCon lhs rhs1, $3)
+ else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } }
fielddecls :: { [LConDeclField GhcPs] }
: {- empty -} { [] }
@@ -2130,7 +2216,7 @@ fielddecl :: { LConDeclField GhcPs }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
{% ams (L (comb2 $2 $4)
- (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))
+ (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- Reversed!
@@ -2146,21 +2232,27 @@ derivings :: { HsDeriving GhcPs }
-- The outer Located is just to allow the caller to
-- know the rightmost extremity of the 'deriving' clause
deriving :: { LHsDerivingClause GhcPs }
- : 'deriving' deriv_strategy qtycondoc
+ : 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause $2 $ L full_loc
- [mkLHsSigType $3])
+ in ams (L full_loc $ HsDerivingClause noExt Nothing $2)
[mj AnnDeriving $1] }
- | 'deriving' deriv_strategy '(' ')'
+ | 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause $2 $ L full_loc [])
- [mj AnnDeriving $1,mop $3,mcp $4] }
+ in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3)
+ [mj AnnDeriving $1] }
- | 'deriving' deriv_strategy '(' deriv_types ')'
+ | 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4)
- [mj AnnDeriving $1,mop $3,mcp $5] }
+ in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2)
+ [mj AnnDeriving $1] }
+
+deriv_clause_types :: { Located [LHsSigType GhcPs] }
+ : qtycondoc { sL1 $1 [mkLHsSigType $1] }
+ | '(' ')' {% ams (sLL $1 $> [])
+ [mop $1,mcp $2] }
+ | '(' deriv_types ')' {% ams (sLL $1 $> $2)
+ [mop $1,mcp $3] }
-- Glasgow extension: allow partial
-- applications in derivings
@@ -2190,7 +2282,7 @@ There's an awkward overlap with a type signature. Consider
-}
docdecl :: { LHsDecl GhcPs }
- : docdecld { sL1 $1 (DocD (unLoc $1)) }
+ : docdecld { sL1 $1 (DocD noExt (unLoc $1)) }
docdecld :: { LDocDecl }
: docnext { sL1 $1 (DocCommentNext (unLoc $1)) }
@@ -2201,35 +2293,34 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
- -- Turn it all into an expression so that
- -- checkPattern can check that bangs are enabled
+ | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
; l = comb2 $1 $> };
(ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+ 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
- -- [Varieties of binding pattern matches]
+ -- [FunBind vs PatBind]
case r of {
- (FunBind n _ _ _ _) ->
+ (FunBind _ n _ _ _) ->
ams (L l ()) [mj AnnFunId n] >> return () ;
- (PatBind (L lh _lhs) _rhs _ _ _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
ams (L lh ()) [] >> return () } ;
_ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
- return $! (sL l $ ValD r) } }
+ return $! (sL l $ ValD noExt r) } }
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $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
- -- [Varieties of binding pattern matches]
+ -- [FunBind vs PatBind]
case r of {
- (FunBind n _ _ _ _) ->
+ (FunBind _ n _ _ _) ->
ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind (L lh _lhs) _rhs _ _ _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
ams (L lh ()) (fst $2) >> return () } ;
_ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
- return $! (sL l $ ValD r) } }
+ return $! (sL l $ ValD noExt r) } }
| pattern_synonym_decl { $1 }
| docdecl { $1 }
@@ -2244,10 +2335,10 @@ decl :: { LHsDecl GhcPs }
rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
: '=' exp wherebinds { sL (comb3 $1 $2 $3)
((mj AnnEqual $1 : (fst $ unLoc $3))
- ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2)
+ ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2)
(snd $ unLoc $3)) }
| gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2
- ,GRHSs (reverse (unLoc $1))
+ ,GRHSs noExt (reverse (unLoc $1))
(snd $ unLoc $2)) }
gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
@@ -2255,7 +2346,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
| gdrh { sL1 $1 [$1] }
gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
- : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+ : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mj AnnEqual $3] }
sigdecl :: { LHsDecl GhcPs }
@@ -2264,69 +2355,69 @@ sigdecl :: { LHsDecl GhcPs }
infixexp_top '::' sigtypedoc
{% do v <- checkValSigLhs $1
; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
- ; return (sLL $1 $> $ SigD $
- TypeSig [v] (mkLHsSigWcType $3)) }
+ ; return (sLL $1 $> $ SigD noExt $
+ TypeSig noExt [v] (mkLHsSigWcType $3)) }
| var ',' sig_vars '::' sigtypedoc
- {% do { let sig = TypeSig ($1 : reverse (unLoc $3))
+ {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3))
(mkLHsSigWcType $5)
; addAnnotation (gl $1) AnnComma (gl $2)
- ; ams ( sLL $1 $> $ SigD sig )
+ ; ams ( sLL $1 $> $ SigD noExt sig )
[mu AnnDcolon $4] } }
| infix prec ops
- {% ams (sLL $1 $> $ SigD
- (FixSig (FixitySig (fromOL $ unLoc $3)
+ {% ams (sLL $1 $> $ SigD noExt
+ (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3)
(Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))
[mj AnnInfix $1,mj AnnVal $2] }
- | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 }
+ | pattern_synonym_sig { sLL $1 $> . SigD noExt . unLoc $ $1 }
| '{-# COMPLETE' con_list opt_tyconsig '#-}'
{% let (dcolon, tc) = $3
in ams
(sLL $1 $>
- (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc)))
+ (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc)))
([ mo $1 ] ++ dcolon ++ [mc $4]) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvar '#-}'
- {% ams ((sLL $1 $> $ SigD (InlineSig $3
+ {% ams ((sLL $1 $> $ SigD noExt (InlineSig noExt $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
(snd $2)))))
((mo $1:fst $2) ++ [mc $4]) }
| '{-# SCC' qvar '#-}'
- {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))
+ {% ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing)))
[mo $1, mc $3] }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc
- ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
+ ; ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
[mo $1, mc $4] } }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% ams (
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
- (EmptyInlineSpec, FunLike) (snd $2)
- in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
+ (NoUserInline, FunLike) (snd $2)
+ in sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) inl_prag))
(mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
+ {% ams (sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1) (snd $2))))
(mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% ams (sLL $1 $>
- $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))
+ $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs $1) $3))
[mo $1,mj AnnInstance $2,mc $4] }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))
+ {% ams (sLL $1 $> $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs $1) $2))
[mo $1,mc $3] }
activation :: { ([AddAnn],Maybe Activation) }
@@ -2354,89 +2445,45 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr GhcPs }
- : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))
+ : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1)
[mu AnnDcolon $2] }
- | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+ | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
HsFirstOrderApp True)
[mu Annlarrowtail $2] }
- | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
HsFirstOrderApp False)
[mu Annrarrowtail $2] }
- | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+ | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
HsHigherOrderApp True)
[mu AnnLarrowtail $2] }
- | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
infixexp :: { LHsExpr GhcPs }
: exp10 { $1 }
- | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+ | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
infixexp_top :: { LHsExpr GhcPs }
: exp10_top { $1 }
| infixexp_top qop exp10_top
- {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+ {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
[mj AnnVal $2] }
-exp10_top :: { LHsExpr GhcPs }
- : '\\' apat apats opt_asig '->' exp
- {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
- [sLL $1 $> $ Match { m_ctxt = LambdaExpr
- , m_pats = $2:$3
- , m_type = snd $4
- , m_grhss = unguardedGRHSs $6 }]))
- (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }
- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
- (mj AnnLet $1:mj AnnIn $3
- :(fst $ unLoc $2)) }
- | '\\' 'lcase' altslist
- {% ams (sLL $1 $> $ HsLamCase
- (mkMatchGroup FromSource (snd $ unLoc $3)))
- (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
- | 'if' exp optSemi 'then' exp optSemi 'else' exp
- {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
- ams (sLL $1 $> $ mkHsIf $2 $5 $8)
- (mj AnnIf $1:mj AnnThen $4
- :mj AnnElse $7
- :(map (\l -> mj AnnSemi l) (fst $3))
- ++(map (\l -> mj AnnSemi l) (fst $6))) }
- | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
- ams (sLL $1 $> $ HsMultiIf
- placeHolderType
- (reverse $ snd $ unLoc $2))
- (mj AnnIf $1:(fst $ unLoc $2)) }
- | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
- FromSource (snd $ unLoc $4)))
- (mj AnnCase $1:mj AnnOf $3
- :(fst $ unLoc $4)) }
- | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
+exp10_top :: { LHsExpr GhcPs }
+ : '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
[mj AnnMinus $1] }
- | 'do' stmtlist {% ams (L (comb2 $1 $2)
- (mkHsDo DoExpr (snd $ unLoc $2)))
- (mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% ams (L (comb2 $1 $2)
- (mkHsDo MDoExpr (snd $ unLoc $2)))
- (mj AnnMdo $1:(fst $ unLoc $2)) }
- | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
+ | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
(snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ fst $ unLoc $1) }
- | 'proc' aexp '->' exp
- {% checkPattern empty $2 >>= \ p ->
- checkCommand $4 >>= \ cmd ->
- ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
- placeHolderType []))
- -- TODO: is LL right here?
- [mj AnnProc $1,mu AnnRarrow $3] }
-
- | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+ | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
[mo $1,mj AnnVal $2
,mc $3] }
-- hdaume: core annotation
@@ -2444,7 +2491,7 @@ exp10_top :: { LHsExpr GhcPs }
exp10 :: { LHsExpr GhcPs }
: exp10_top { $1 }
- | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+ | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located a],Bool) }
@@ -2487,19 +2534,65 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
}
fexp :: { LHsExpr GhcPs }
- : fexp aexp { sLL $1 $> $ HsApp $1 $2 }
- | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+ : fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >>
+ return (sLL $1 $> $ (HsApp noExt $1 $2)) }
+ | fexp TYPEAPP atype {% checkBlockArguments $1 >>
+ ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1)
[mj AnnAt $2] }
- | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)
+ | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2)
[mj AnnStatic $1] }
| aexp { $1 }
aexp :: { LHsExpr GhcPs }
- : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
+ : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
-- If you change the parsing, make sure to understand
-- Note [Lexing type applications] in Lexer.x
- | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
+ | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] }
+
+ | '\\' apat apats '->' exp
+ {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource
+ [sLL $1 $> $ Match { m_ext = noExt
+ , m_ctxt = LambdaExpr
+ , m_pats = $2:$3
+ , m_grhss = unguardedGRHSs $5 }]))
+ [mj AnnLam $1, mu AnnRarrow $4] }
+ | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4)
+ (mj AnnLet $1:mj AnnIn $3
+ :(fst $ unLoc $2)) }
+ | '\\' 'lcase' altslist
+ {% ams (sLL $1 $> $ HsLamCase noExt
+ (mkMatchGroup FromSource (snd $ unLoc $3)))
+ (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
+ | 'if' exp optSemi 'then' exp optSemi 'else' exp
+ {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
+ ams (sLL $1 $> $ mkHsIf $2 $5 $8)
+ (mj AnnIf $1:mj AnnThen $4
+ :mj AnnElse $7
+ :(map (\l -> mj AnnSemi l) (fst $3))
+ ++(map (\l -> mj AnnSemi l) (fst $6))) }
+ | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
+ ams (sLL $1 $> $ HsMultiIf noExt
+ (reverse $ snd $ unLoc $2))
+ (mj AnnIf $1:(fst $ unLoc $2)) }
+ | 'case' exp 'of' altslist {% ams (L (comb3 $1 $3 $4) $
+ HsCase noExt $2 (mkMatchGroup
+ FromSource (snd $ unLoc $4)))
+ (mj AnnCase $1:mj AnnOf $3
+ :(fst $ unLoc $4)) }
+ | 'do' stmtlist {% ams (L (comb2 $1 $2)
+ (mkHsDo DoExpr (snd $ unLoc $2)))
+ (mj AnnDo $1:(fst $ unLoc $2)) }
+ | 'mdo' stmtlist {% ams (L (comb2 $1 $2)
+ (mkHsDo MDoExpr (snd $ unLoc $2)))
+ (mj AnnMdo $1:(fst $ unLoc $2)) }
+ | 'proc' aexp '->' exp
+ {% checkPattern empty $2 >>= \ p ->
+ checkCommand $4 >>= \ cmd ->
+ ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
+ -- TODO: is LL right here?
+ [mj AnnProc $1,mu AnnRarrow $3] }
+
| aexp1 { $1 }
aexp1 :: { LHsExpr GhcPs }
@@ -2510,72 +2603,70 @@ aexp1 :: { LHsExpr GhcPs }
| aexp2 { $1 }
aexp2 :: { LHsExpr GhcPs }
- : qvar { sL1 $1 (HsVar $! $1) }
- | qcon { sL1 $1 (HsVar $! $1) }
- | ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
- | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) }
- | literal { sL1 $1 (HsLit $! unLoc $1) }
+ : qvar { sL1 $1 (HsVar noExt $! $1) }
+ | qcon { sL1 $1 (HsVar noExt $! $1) }
+ | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) }
+ | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) }
+ | literal { sL1 $1 (HsLit noExt $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
--- (getSTRING $1) placeHolderType) }
- | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral
- (getINTEGER $1) placeHolderType) }
- | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional
- (getRATIONAL $1) placeHolderType) }
+-- (getSTRING $1) noExt) }
+ | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) }
+ | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) }
-- N.B.: sections get parsed by these next two productions.
-- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
- | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
+ | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
- | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
- (Present $2)] Unboxed))
+ | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
+ (Present noExt $2)] Unboxed))
[mo $1,mc $3] }
| '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
| '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
- | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
- | '_' { sL1 $1 EWildPat }
+ | '_' { sL1 $1 $ EWildPat noExt }
-- Template Haskell Extension
| splice_exp { $1 }
- | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
+ | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+ | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
+ | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
(if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
- | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
+ | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
- | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] }
+ | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
| '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
- ams (sLL $1 $> $ HsBracket (PatBr p))
+ ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
- | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2)))
+ | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
(mo $1:mu AnnCloseQ $3:fst $2) }
- | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) }
+ | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
-- arrow notation extension
- | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2
+ | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2
Nothing (reverse $3))
[mu AnnOpenB $1,mu AnnCloseB $4] }
splice_exp :: { LHsExpr GhcPs }
: TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_SPLICE $1)))))
[mj AnnThIdSplice $1] }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
| TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar
- (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+ (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_TY_SPLICE $1)))))
[mj AnnThIdTySplice $1] }
| '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
@@ -2587,8 +2678,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
acmd :: { LHsCmdTop GhcPs }
: aexp2 {% checkCommand $1 >>= \ cmd ->
- return (sL1 $1 $ HsCmdTop cmd
- placeHolderType placeHolderType []) }
+ return (sL1 $1 $ HsCmdTop noExt cmd) }
cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
: '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
@@ -2619,17 +2709,17 @@ texp :: { LHsExpr GhcPs }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
- | infixexp qop { sLL $1 $> $ SectionL $1 $2 }
- | qopm infixexp { sLL $1 $> $ SectionR $1 $2 }
+ | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 }
+ | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 }
-- View patterns get parenthesized above
- | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
+ | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
-- Always at least one comma or bar.
tup_exprs :: { ([AddAnn],SumOrTuple) }
: texp commas_tup_tail
{% do { addAnnotation (gl $1) AnnComma (fst $2)
- ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+ ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
| texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) }
@@ -2652,8 +2742,8 @@ commas_tup_tail : commas tup_tail
-- Always follows a comma
tup_tail :: { [LHsTupArg GhcPs] }
: texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
- return ((L (gl $1) (Present $1)) : snd $2) }
- | texp { [L (gl $1) (Present $1)] }
+ return ((L (gl $1) (Present noExt $1)) : snd $2) }
+ | texp { [L (gl $1) (Present noExt $1)] }
| {- empty -} { [noLoc missingTupArg] }
-----------------------------------------------------------------------------
@@ -2662,19 +2752,18 @@ tup_tail :: { [LHsTupArg GhcPs] }
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
list :: { ([AddAnn],HsExpr GhcPs) }
- : texp { ([],ExplicitList placeHolderType Nothing [$1]) }
- | lexps { ([],ExplicitList placeHolderType Nothing
- (reverse (unLoc $1))) }
+ : texp { ([],ExplicitList noExt Nothing [$1]) }
+ | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) }
| texp '..' { ([mj AnnDotdot $2],
- ArithSeq noPostTcExpr Nothing (From $1)) }
+ ArithSeq noExt Nothing (From $1)) }
| texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromThen $1 $3)) }
| texp '..' exp { ([mj AnnDotdot $2],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromTo $1 $3)) }
| texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
- ArithSeq noPostTcExpr Nothing
+ ArithSeq noExt Nothing
(FromThenTo $1 $3 $5)) }
| texp '|' flattenedpquals
{% checkMonadComp >>= \ ctxt ->
@@ -2697,9 +2786,9 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+ qss -> sL1 $1 [sL1 $1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr |
qs <- qss]
- noExpr noSyntaxExpr placeHolderType]
+ noExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
-- we wrap them into as a ParStmt
}
@@ -2746,29 +2835,6 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
-- in by choosing the "group by" variant, which is what we want.
-----------------------------------------------------------------------------
--- Parallel array expressions
-
--- The rules below are little bit contorted; see the list case for details.
--- Note that, in contrast to lists, we only have finite arithmetic sequences.
--- Moreover, we allow explicit arrays with no element (represented by the nil
--- constructor in the list case).
-
-parr :: { ([AddAnn],HsExpr GhcPs) }
- : { ([],ExplicitPArr placeHolderType []) }
- | texp { ([],ExplicitPArr placeHolderType [$1]) }
- | lexps { ([],ExplicitPArr placeHolderType
- (reverse (unLoc $1))) }
- | texp '..' exp { ([mj AnnDotdot $2]
- ,PArrSeq noPostTcExpr (FromTo $1 $3)) }
- | texp ',' exp '..' exp
- { ([mj AnnComma $2,mj AnnDotdot $4]
- ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) }
- | texp '|' flattenedpquals
- { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) }
-
--- We are reusing `lexps' and `flattenedpquals' from the list case.
-
------------------------------------------------------------------------------
-- Guards
guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
@@ -2788,7 +2854,7 @@ altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
,(reverse (snd $ unLoc $2))) }
| vocurly alts close { L (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
- | '{' '}' { noLoc ([moc $1,mcc $2],[]) }
+ | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) }
| vocurly close { noLoc ([],[]) }
alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
@@ -2812,15 +2878,15 @@ alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
| alt { sL1 $1 ([],[$1]) }
alt :: { LMatch GhcPs (LHsExpr GhcPs) }
- : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt
- , m_pats = [$1]
- , m_type = snd $2
- , m_grhss = snd $ unLoc $3 }))
- (fst $2 ++ (fst $ unLoc $3))}
+ : pat alt_rhs {%ams (sLL $1 $> (Match { m_ext = noExt
+ , m_ctxt = CaseAlt
+ , m_pats = [$1]
+ , m_grhss = snd $ unLoc $2 }))
+ (fst $ unLoc $2)}
alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
: ralt wherebinds { sLL $1 $> (fst $ unLoc $2,
- GRHSs (unLoc $1) (snd $ unLoc $2)) }
+ GRHSs noExt (unLoc $1) (snd $ unLoc $2)) }
ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
: '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
@@ -2840,7 +2906,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) }
: '|' guardquals '->' exp
- {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+ {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mu AnnRarrow $3] }
-- 'pat' recognises a pattern, including one with a bang at the top
@@ -2849,8 +2915,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) }
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
pat : exp {% checkPattern empty $1 }
- | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt
+ (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
@@ -2858,14 +2924,14 @@ bindpat : exp {% checkPattern
(text "Possibly caused by a missing 'do'?") $1 }
| '!' aexp {% amms (checkPattern
(text "Possibly caused by a missing 'do'?")
- (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
apat : aexp {% checkPattern empty $1 }
| '!' aexp {% amms (checkPattern empty
- (sLL $1 $> (SectionR
- (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+ (sLL $1 $> (SectionR noExt
+ (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apats :: { [LPat GhcPs] }
@@ -2920,7 +2986,7 @@ qual :: { LStmt GhcPs (LHsExpr GhcPs) }
: bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3)
[mu AnnLarrow $2] }
| exp { sL1 $1 $ mkBodyStmt $1 }
- | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))
+ | 'let' binds {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
-----------------------------------------------------------------------------
@@ -2962,7 +3028,7 @@ dbinds :: { Located [LIPBind GhcPs] }
-- | {- empty -} { [] }
dbind :: { LIPBind GhcPs }
-dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3))
+dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3))
[mj AnnEqual $2] }
ipvar :: { Located HsIPName }
@@ -3027,8 +3093,6 @@ gen_qcon :: { Located RdrName }
| '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2))
[mop $1,mj AnnVal $2,mcp $3] }
--- The case of '[:' ':]' is part of the production `parr'
-
con :: { Located RdrName }
: conid { $1 }
| '(' consym ')' {% ams (sLL $1 $> (unLoc $2))
@@ -3088,9 +3152,6 @@ ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit
| '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
[mop $1,mu AnnRarrow $2,mcp $3] }
| '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
- [mop $1,mj AnnTildehsh $2,mcp $3] }
oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon;
-- These can appear in export lists
@@ -3143,8 +3204,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified
- : qtycon { sL1 $1 (HsTyVar NotPromoted $1) }
- | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
+ : qtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) }
+ | qtycon docprev { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) }
tycon :: { Located RdrName } -- Unqualified
: CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
@@ -3177,15 +3238,19 @@ varop :: { Located RdrName }
,mj AnnBackquote $3] }
qop :: { LHsExpr GhcPs } -- used in sections
- : qvarop { sL1 $1 $ HsVar $1 }
- | qconop { sL1 $1 $ HsVar $1 }
- | '`' '_' '`' {% ams (sLL $1 $> EWildPat)
- [mj AnnBackquote $1,mj AnnVal $2
- ,mj AnnBackquote $3] }
+ : qvarop { sL1 $1 $ HsVar noExt $1 }
+ | qconop { sL1 $1 $ HsVar noExt $1 }
+ | hole_op { $1 }
qopm :: { LHsExpr GhcPs } -- used in sections
- : qvaropm { sL1 $1 $ HsVar $1 }
- | qconop { sL1 $1 $ HsVar $1 }
+ : qvaropm { sL1 $1 $ HsVar noExt $1 }
+ | qconop { sL1 $1 $ HsVar noExt $1 }
+ | hole_op { $1 }
+
+hole_op :: { LHsExpr GhcPs } -- used in sections
+hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt)
+ [mj AnnBackquote $1,mj AnnVal $2
+ ,mj AnnBackquote $3] }
qvarop :: { Located RdrName }
: qvarsym { $1 }
@@ -3298,6 +3363,7 @@ special_id
| 'group' { sL1 $1 (fsLit "group") }
| 'stock' { sL1 $1 (fsLit "stock") }
| 'anyclass' { sL1 $1 (fsLit "anyclass") }
+ | 'via' { sL1 $1 (fsLit "via") }
| 'unit' { sL1 $1 (fsLit "unit") }
| 'dependency' { sL1 $1 (fsLit "dependency") }
| 'signature' { sL1 $1 (fsLit "signature") }
@@ -3305,6 +3371,7 @@ special_id
special_sym :: { Located FastString }
special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
| '.' { sL1 $1 (fsLit ".") }
+ | '*' { sL1 $1 (fsLit (if isUnicode $1 then "\x2605" else "*")) }
-----------------------------------------------------------------------------
-- Data constructors
@@ -3331,19 +3398,19 @@ consym :: { Located RdrName }
-- Literals
literal :: { Located (HsLit GhcPs) }
- : CHAR { sL1 $1 $ HsChar (sst $ getCHARs $1) $ getCHAR $1 }
- | STRING { sL1 $1 $ HsString (sst $ getSTRINGs $1)
- $ getSTRING $1 }
- | PRIMINTEGER { sL1 $1 $ HsIntPrim (sst $ getPRIMINTEGERs $1)
- $ getPRIMINTEGER $1 }
- | PRIMWORD { sL1 $1 $ HsWordPrim (sst $ getPRIMWORDs $1)
- $ getPRIMWORD $1 }
- | PRIMCHAR { sL1 $1 $ HsCharPrim (sst $ getPRIMCHARs $1)
- $ getPRIMCHAR $1 }
- | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1)
- $ getPRIMSTRING $1 }
- | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 }
- | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 }
+ : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 }
+ | STRING { sL1 $1 $ HsString (getSTRINGs $1)
+ $ getSTRING $1 }
+ | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1)
+ $ getPRIMINTEGER $1 }
+ | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1)
+ $ getPRIMWORD $1 }
+ | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1)
+ $ getPRIMCHAR $1 }
+ | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)
+ $ getPRIMSTRING $1 }
+ | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExt $ getPRIMFLOAT $1 }
+ | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 }
-----------------------------------------------------------------------------
-- Layout
@@ -3379,24 +3446,24 @@ bars :: { ([SrcSpan],Int) } -- One or more bars
-- Documentation comments
docnext :: { LHsDocString }
- : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
+ : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) }
docprev :: { LHsDocString }
- : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) }
+ : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) }
docnamed :: { Located (String, HsDocString) }
: DOCNAMED {%
let string = getDOCNAMED $1
(name, rest) = break isSpace string
- in return (sL1 $1 (name, HsDocString (mkFastString rest))) }
+ in return (sL1 $1 (name, mkHsDocString rest)) }
docsection :: { Located (Int, HsDocString) }
: DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
- return (sL1 $1 (n, HsDocString (mkFastString doc))) }
+ return (sL1 $1 (n, mkHsDocString doc)) }
moduleheader :: { Maybe LHsDocString }
: DOCNEXT {% let string = getDOCNEXT $1 in
- return (Just (sL1 $1 (HsDocString (mkFastString string)))) }
+ return (Just (sL1 $1 (mkHsDocString string))) }
maybe_docprev :: { Maybe LHsDocString }
: docprev { Just $1 }
@@ -3464,9 +3531,6 @@ 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
-getVECT_PRAGs (L _ (ITvect_prag src)) = src
-getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src
-getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src
getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src
getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src
@@ -3490,6 +3554,7 @@ 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
@@ -3625,6 +3690,24 @@ hintExplicitForall' span = do
, text "extension to enable explicit-forall syntax: forall <tvs>. <type>"
]
+-- When two single quotes don't followed by tyvar or gtycon, we report the
+-- error as empty character literal, or TH quote that missing proper type
+-- variable or constructor. See Trac #13450.
+reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
+reportEmptyDoubleQuotes span = do
+ thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
+ if thEnabled
+ then parseErrorSDoc span $ vcat
+ [ text "Parser error on `''`"
+ , text "Character literals may not be empty"
+ , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
+ , text "but the type variable or constructor is missing"
+ ]
+ else parseErrorSDoc span $ vcat
+ [ text "Parser error on `''`"
+ , text "Character literals may not be empty"
+ ]
+
{-
%************************************************************************
%* *
@@ -3740,7 +3823,4 @@ oll l =
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
-
-sst ::HasSourceText a => SourceText -> a
-sst = setSourceText
}
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f2c8b33000..5784b9ecdb 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
module RdrHsSyn (
mkHsOpApp,
@@ -41,8 +42,10 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for
-- checking and constructing values
+ checkBlockArguments,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
+ checkInfixConstr,
checkPattern, -- HsExp -> P HsPat
bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -52,8 +55,10 @@ module RdrHsSyn (
checkValSigLhs,
checkDoAndIfThenElse,
checkRecordSyntax,
- parseErrorSDoc,
- splitTilde, splitTildeApps,
+ checkEmptyGADTs,
+ parseErrorSDoc, hintBangPat,
+ splitTilde,
+ TyEl(..), mergeOps,
-- Help with processing exports
ImpExpSubSpec(..),
@@ -63,12 +68,16 @@ module RdrHsSyn (
mkImpExpSubSpec,
checkImportSpec,
+ -- Warnings and errors
+ warnStarIsType,
+ failOpFewArgs,
+
SumOrTuple (..), mkSumOrTuple
) where
+import GhcPrelude
import HsSyn -- Lots of it
-import Class ( FunDep )
import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon ( DataCon, dataConTyCon )
import ConLike ( ConLike(..) )
@@ -82,10 +91,9 @@ import Lexeme ( isLexCon )
import Type ( TyThing(..) )
import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
- listTyConName, listTyConKey,
- starKindTyConName, unicodeStarKindTyConName )
+ listTyConName, listTyConKey, eqTyCon_RDR )
import ForeignCall
-import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
+import PrelNames ( forall_tv_RDR, allNameStrings )
import SrcLoc
import Unique ( hasKey )
import OrdList ( OrdList, fromOL )
@@ -95,9 +103,10 @@ import FastString
import Maybes
import Util
import ApiAnnotation
+import HsExtension ( noExt )
import Data.List
import qualified GHC.LanguageExtensions as LangExt
-import MonadUtils
+import DynFlags ( WarningFlag(..) )
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
@@ -124,15 +133,15 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
-- *** See Note [The Naming story] in HsDecls ****
-mkTyClD :: LTyClDecl n -> LHsDecl n
-mkTyClD (L loc d) = L loc (TyClD d)
+mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
+mkTyClD (L loc d) = L loc (TyClD noExt d)
-mkInstD :: LInstDecl n -> LHsDecl n
-mkInstD (L loc d) = L loc (InstD d)
+mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
+mkInstD (L loc d) = L loc (InstD noExt d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
- -> Located (a,[Located (FunDep (Located RdrName))])
+ -> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
@@ -143,13 +152,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
; at_defs <- mapM (eitherToP . mkATDefault) at_insts
- ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
+ ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
+ , tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
, tcdFDs = snd (unLoc fds)
, tcdSigs = mkClassOpSigs sigs
, tcdMeths = binds
- , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs
- , tcdFVs = placeHolderNames })) }
+ , tcdATs = ats, tcdATDefs = at_defs
+ , tcdDocs = docs })) }
mkATDefault :: LTyFamInstDecl GhcPs
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
@@ -159,14 +169,17 @@ mkATDefault :: LTyFamInstDecl GhcPs
--
-- We use the Either monad because this also called
-- from Convert.hs
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
- | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
- , tfe_rhs = rhs } <- e
- = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
- ; return (L loc (TyFamEqn { tfe_tycon = tc
- , tfe_pats = tvs
- , tfe_fixity = fixity
- , tfe_rhs = rhs })) }
+mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+ | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs } <- e
+ = do { tvs <- checkTyVars (text "default") equalsDots tc pats
+ ; return (L loc (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc
+ , feqn_pats = tvs
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })) }
+mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
+mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
mkTyData :: SrcSpan
-> NewOrData
@@ -181,11 +194,10 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
+ ; return (L loc (DataDecl { tcdDExt = noExt,
+ tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
- tcdDataDefn = defn,
- tcdDataCusk = PlaceHolder,
- tcdFVs = placeHolderNames })) }
+ tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe (Located CType)
@@ -197,7 +209,8 @@ mkDataDefn :: NewOrData
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
- ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+ ; return (HsDataDefn { dd_ext = noExt
+ , dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = cxt
, dd_cons = data_cons
, dd_kindSig = ksig
@@ -212,19 +225,22 @@ mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
- ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
+ ; return (L loc (SynDecl { tcdSExt = noExt
+ , tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
- , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
+ , tcdRhs = rhs })) }
mkTyFamInstEqn :: LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (TyFamEqn { tfe_tycon = tc
- , tfe_pats = mkHsImplicitBndrs tparams
- , tfe_fixity = fixity
- , tfe_rhs = rhs },
+ ; return (mkHsImplicitBndrs
+ (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc
+ , feqn_pats = tparams
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs }),
ann) }
mkDataFamInst :: SrcSpan
@@ -239,18 +255,18 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataFamInstD (
- DataFamInstDecl { dfid_tycon = tc
- , dfid_pats = mkHsImplicitBndrs tparams
- , dfid_fixity = fixity
- , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
+ ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
+ (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc
+ , feqn_pats = tparams
+ , feqn_fixity = fixity
+ , feqn_rhs = defn }))))) }
mkTyFamInst :: SrcSpan
- -> LTyFamInstEqn GhcPs
+ -> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
- = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn
- , tfid_fvs = placeHolderNames })))
+ = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
@@ -262,7 +278,9 @@ mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
- ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc
+ ; return (L loc (FamDecl noExt (FamilyDecl
+ { fdExt = noExt
+ , fdInfo = info, fdLName = tc
, fdTyVars = tyvars
, fdFixity = fixity
, fdResultSig = ksig
@@ -284,14 +302,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@(L loc expr)
- | HsSpliceE splice@(HsUntypedSplice {}) <- expr
- = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+ | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
+ = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
- | HsSpliceE splice@(HsQuasiQuote {}) <- expr
- = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+ | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
+ = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
| otherwise
- = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
+ = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
+ ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName -- type being annotated
@@ -299,7 +318,7 @@ mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
- ; return $ L loc $ RoleAnnotDecl tycon roles' }
+ ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
where
role_data_type = dataTypeOf (undefined :: Role)
all_roles = map fromConstr $ dataTypeConstrs role_data_type
@@ -337,17 +356,17 @@ cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
cvTopDecls decls = go (fromOL decls)
where
go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
- go [] = []
- go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
+ go [] = []
+ 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
+ go (d : ds) = d : go ds
-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
cvBindGroup binding
= do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
- return $ ValBindsIn mbs sigs }
+ return $ ValBinds noExt mbs sigs }
cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
@@ -358,7 +377,7 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = return (emptyBag, [], [], [], [], [])
- go (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
@@ -366,17 +385,17 @@ cvBindsAndSigs fb = go (fromOL fb)
go (L l decl : ds)
= do { (bs, ss, ts, tfis, dfis, docs) <- go ds
; case decl of
- SigD s
+ SigD _ s
-> return (bs, L l s : ss, ts, tfis, dfis, docs)
- TyClD (FamDecl t)
+ TyClD _ (FamDecl _ t)
-> return (bs, ss, L l t : ts, tfis, dfis, docs)
- InstD (TyFamInstD { tfid_inst = tfi })
+ InstD _ (TyFamInstD { tfid_inst = tfi })
-> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
- InstD (DataFamInstD { dfid_inst = dfi })
+ InstD _ (DataFamInstD { dfid_inst = dfi })
-> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
- DocD d
+ DocD _ d
-> return (bs, ss, ts, tfis, dfis, L l d : docs)
- SpliceD d
+ SpliceD _ d
-> parseErrorSDoc l $
hang (text "Declaration splices are allowed only" <+>
text "at the top level:")
@@ -408,12 +427,12 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
= go mtchs1 loc1 binds []
where
go mtchs loc
- (L loc2 (ValD (FunBind { fun_id = L _ f2,
- fun_matches
- = MG { mg_alts = L _ mtchs2 } })) : binds) _
+ (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@(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
@@ -425,12 +444,13 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
-has_args [] = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match _ 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 ((L _ (XMatch _)) : _) = panic "has_args"
{- **********************************************************************
@@ -452,7 +472,8 @@ So the plan is:
* Parse the data constructor declration as a type (actually btype_no_ops)
-* Use 'splitCon' to rejig it into the data constructor and the args
+* Use 'splitCon' to rejig it into the data constructor, the args, and possibly
+ extract a docstring for the constructor
* In doing so, we use 'tyConToDataCon' to convert the RdrName for
the data con, which has been parsed as a tycon, back to a datacon.
@@ -461,28 +482,58 @@ So the plan is:
data T = (+++)
will parse ok (since tycons can be operators), but we should reject
it (Trac #12051).
+
+'splitCon' takes a reversed list @apps@ of types as input, such that
+@foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
+this is easy for the parser to produce and we avoid the overhead of unrolling
+'HsAppTy'.
+
-}
-splitCon :: LHsType GhcPs
- -> P (Located RdrName, HsConDeclDetails GhcPs)
+splitCon :: [LHsType GhcPs]
+ -> P ( Located RdrName -- constructor name
+ , HsConDeclDetails GhcPs -- constructor field information
+ , Maybe LHsDocString -- docstring to go on the constructor
+ )
-- See Note [Parsing data constructors is hard]
-- This gets given a "type" that should look like
-- C Int Bool
-- or C { x::Int, y::Bool }
-- and returns the pieces
-splitCon ty
- = split ty []
+splitCon apps
+ = split apps' []
where
- -- This is used somewhere where HsAppsTy is not used
- split (L _ (HsAppTy t u)) ts = split t (u : ts)
- split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc
- return (data_con, mk_rest ts)
- split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
- = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
- split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
-
- mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
- mk_rest ts = PrefixCon ts
+ oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
+ ty = foldl1 mkHsAppTy (reverse apps)
+
+ -- the trailing doc, if any, can be extracted first
+ (apps', trailing_doc)
+ = case apps of
+ L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
+ ts -> (ts, Nothing)
+
+ -- A comment on the constructor is handled a bit differently - it doesn't
+ -- remain an 'HsDocTy', but gets lifted out and returned as the third
+ -- element of the tuple.
+ split [ L _ (HsDocTy _ con con_doc) ] ts = do
+ (data_con, con_details, con_doc') <- split [con] ts
+ return (data_con, con_details, con_doc' `mplus` Just con_doc)
+ split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
+ data_con <- tyConToDataCon l tc
+ return (data_con, mk_rest ts, trailing_doc)
+ split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
+ = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
+ , PrefixCon ts
+ , trailing_doc
+ )
+ split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
+ where msg = "Cannot parse data constructor in a data/newtype declaration:"
+ split (u : us) ts = split us (u : ts)
+ split _ _ = panic "RdrHsSyn:splitCon"
+
+ mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
+ mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
+ mk_rest ts = PrefixCon ts
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-- See Note [Parsing data constructors is hard]
@@ -502,6 +553,22 @@ tyConToDataCon loc tc
= text "Perhaps you intended to use ExistentialQuantification"
| otherwise = empty
+-- | Split a type to extract the trailing doc string (if there is one) from a
+-- type produced by the 'btype_no_ops' production.
+splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
+splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
+ where ~(t2', ds) = splitDocTy t2
+splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
+splitDocTy ty = (ty, Nothing)
+
+-- | Given a type that is a field to an infix data constructor, try to split
+-- off a trailing docstring on the type, and check that there are no other
+-- docstrings.
+checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
+checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
+ where (ty', doc_string) = splitDocTy ty
+ msg = text "infix constructor field"
+
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl GhcPs))
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
@@ -510,14 +577,25 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
; when (null matches) (wrongNumberErr loc)
; return $ mkMatchGroup FromSource matches }
where
- fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(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
- PrefixCon pats ->
- return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
- InfixCon pat1 pat2 ->
- return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
+ PrefixCon pats -> return $ Match { m_ext = noExt
+ , m_ctxt = ctxt, m_pats = pats
+ , m_grhss = rhs }
+ where
+ ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
+
+ InfixCon p1 p2 -> return $ Match { m_ext = noExt
+ , m_ctxt = ctxt
+ , m_pats = [p1, p2]
+ , m_grhss = rhs }
+ where
+ ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
+
RecCon{} -> recordPatSynErr loc pat
; return $ L loc match }
fromDecl (L loc decl) = extraDeclErr loc decl
@@ -544,24 +622,76 @@ recordPatSynErr loc pat =
ppr pat
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
- -> LHsContext GhcPs -> HsConDeclDetails GhcPs
+ -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
-> ConDecl GhcPs
-mkConDeclH98 name mb_forall cxt details
- = ConDeclH98 { con_name = name
- , con_qvars = fmap mkHsQTvs mb_forall
- , con_cxt = Just cxt
- -- AZ:TODO: when can cxt be Nothing?
- -- remembering that () is a valid context.
- , con_details = details
- , con_doc = Nothing }
+mkConDeclH98 name mb_forall mb_cxt args
+ = ConDeclH98 { con_ext = noExt
+ , con_name = name
+ , con_forall = noLoc $ isJust mb_forall
+ , con_ex_tvs = mb_forall `orElse` []
+ , con_mb_cxt = mb_cxt
+ , con_args = args'
+ , con_doc = Nothing }
+ where
+ args' = nudgeHsSrcBangs args
mkGadtDecl :: [Located RdrName]
- -> LHsSigType GhcPs -- Always a HsForAllTy
- -> ConDecl GhcPs
-mkGadtDecl names ty = ConDeclGADT { con_names = names
- , con_type = ty
- , con_doc = Nothing }
+ -> LHsType GhcPs -- Always a HsForAllTy
+ -> (ConDecl GhcPs, [AddAnn])
+mkGadtDecl names ty
+ = (ConDeclGADT { con_g_ext = noExt
+ , con_names = names
+ , con_forall = L l $ isLHsForAllTy ty'
+ , con_qvars = mkHsQTvs tvs
+ , con_mb_cxt = mcxt
+ , con_args = args'
+ , con_res_ty = res_ty
+ , con_doc = Nothing }
+ , anns1 ++ anns2)
+ where
+ (ty'@(L l _),anns1) = peel_parens ty []
+ (tvs, rho) = splitLHsForAllTy ty'
+ (mcxt, tau, anns2) = split_rho rho []
+
+ split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+ = (Just cxt, tau, ann)
+ split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
+ split_rho tau ann = (Nothing, tau, ann)
+
+ (args, res_ty) = split_tau tau
+ args' = nudgeHsSrcBangs args
+
+ -- See Note [GADT abstract syntax] in HsDecls
+ split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
+ = (RecCon (L loc rf), res_ty)
+ split_tau tau = (PrefixCon [], tau)
+
+ peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
+ (ann++mkParensApiAnn l)
+ peel_parens ty ann = (ty, ann)
+
+nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
+-- ^ This function ensures that fields with strictness or packedness
+-- annotations put these annotations on an outer 'HsBangTy'.
+--
+-- The problem is that in the parser, strictness and packedness annotations
+-- bind more tightly that docstrings. However, the expectation downstream of
+-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
+-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
+-- top-level type.
+--
+-- See #15206
+nudgeHsSrcBangs details
+ = case details of
+ PrefixCon as -> PrefixCon (map go as)
+ RecCon r -> RecCon r
+ InfixCon a1 a2 -> InfixCon (go a1) (go a2)
+ where
+ go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
+ L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
+ go lty = lty
+
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
@@ -648,23 +778,6 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
really doesn't matter!
-}
--- | Note [Sorting out the result type]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a GADT declaration which is not a record, we put the whole constr type
--- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
--- it has sorted out operator fixities. Consider for example
--- C :: a :*: b -> a :*: b -> a :+: b
--- Initially this type will parse as
--- a :*: (b -> (a :*: (b -> (a :+: b))))
---
--- so it's hard to split up the arguments until we've done the precedence
--- resolution (in the renamer). On the other hand, for a record
--- { x,y :: Int } -> a :*: b
--- there is no doubt. AND we need to sort records out so that
--- we can bring x,y into scope. So:
--- * For PrefixCon we keep all the args in the res_ty
--- * For RecCon we do not
-
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
-> P (LHsQTyVars GhcPs)
-- Same as checkTyVars, but in the P monad
@@ -686,16 +799,13 @@ checkTyVars pp_what equals_or_where tc tparms
= do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-
- chk (L _ (HsParTy ty)) = chk ty
- chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
+ chk (L _ (HsParTy _ ty)) = chk ty
-- Check that the name space is correct!
- chk (L l (HsKindSig
- (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
- | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
- chk (L l (HsTyVar _ (L ltv tv)))
- | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
+ chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k))
+ chk (L l (HsTyVar _ _ (L ltv tv)))
+ | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv)))
chk t@(L loc _)
= Left (loc,
vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -728,6 +838,21 @@ checkRecordSyntax lr@(L loc r)
(text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
ppr r)
+-- | Check if the gadt_constrlist is empty. Only raise parse error for
+-- `data T where` to avoid affecting existing error message, see #8258.
+checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
+ -> P (Located ([AddAnn], [LConDecl GhcPs]))
+checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
+ = do opts <- fmap options getPState
+ if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax
+ then return gadts
+ else parseErrorSDoc span $ vcat
+ [ text "Illegal keyword 'where' in data declaration"
+ , text "Perhaps you intended to use GADTs or a similar language"
+ , text "extension to enable syntax: data T where"
+ ]
+checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
+
checkTyClHdr :: Bool -- True <=> class header
-- False <=> type header
-> LHsType GhcPs
@@ -744,23 +869,20 @@ checkTyClHdr is_cls ty
where
goL (L l ty) acc ann fix = go l ty acc ann fix
- go l (HsTyVar _ (L _ tc)) acc ann fix
+ -- workaround to define '*' despite StarIsType
+ go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
+ = do { warnStarBndr l
+ ; let name = mkOccName tcClsName (if isUni then "★" else "*")
+ ; return (L l (Unqual name), acc, fix, ann) }
+
+ go l (HsTyVar _ _ (L _ tc)) acc ann fix
| isRdrTc tc = return (L l tc, acc, fix, ann)
- go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
| isRdrTc tc = return (ltc, t1: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 (t2:acc) ann fix
- go _ (HsAppsTy ts) acc ann _fix
- | Just (head, args, fixity) <- getAppsTyHead_maybe ts
- = goL head (args ++ acc) ann fixity
-
- go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
- | isStar star
- = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
- | isUniStar star
- = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
-
- go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
+ go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
+ go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
+
+ go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (L l (nameRdrName tup_name), ts, fix, ann)
where
arity = length ts
@@ -771,24 +893,68 @@ checkTyClHdr is_cls ty
= parseErrorSDoc l (text "Malformed head of type or class declaration:"
<+> ppr ty)
+-- | Yield a parse error if we have a function applied directly to a do block
+-- etc. and BlockArguments is not enabled.
+checkBlockArguments :: LHsExpr GhcPs -> P ()
+checkBlockArguments expr = case unLoc expr of
+ HsDo _ DoExpr _ -> check "do block"
+ HsDo _ MDoExpr _ -> check "mdo block"
+ HsLam {} -> check "lambda expression"
+ HsCase {} -> check "case expression"
+ HsLamCase {} -> check "lambda-case expression"
+ HsLet {} -> check "let expression"
+ HsIf {} -> check "if expression"
+ HsProc {} -> check "proc expression"
+ _ -> return ()
+ where
+ check element = do
+ pState <- getPState
+ unless (extopt LangExt.BlockArguments (options pState)) $
+ parseErrorSDoc (getLoc expr) $
+ text "Unexpected " <> text element <> text " in function application:"
+ $$ nest 4 (ppr expr)
+ $$ text "You could write it with parentheses"
+ $$ text "Or perhaps you meant to enable BlockArguments?"
+
+-- | Validate the context constraints and break up a context into a list
+-- of predicates.
+--
+-- @
+-- (Eq a, Ord b) --> [Eq a, Ord b]
+-- Eq a --> [Eq a]
+-- (Eq a) --> [Eq a]
+-- (((Eq a))) --> [Eq a]
+-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext (L l orig_t)
= check [] (L l orig_t)
where
- check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
+ 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,L l ts) -- Ditto ()
- -- don't let HsAppsTy get in the way
- check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
- = check anns ty
-
- check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
+ 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)
- check _anns _
- = return ([],L l [L l orig_t]) -- no need for anns, returning original
+ -- no need for anns, returning original
+ check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
+
+ msg = text "data constructor context"
+
+-- | Check recursively if there are any 'HsDocTy's in the given type.
+-- This only works on a subset of types produced by 'btype_no_ops'
+checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
+checkNoDocs msg ty = go ty
+ where
+ go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+ go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
+ [ text "Unexpected haddock", quotes (ppr ds)
+ , text "on", msg, quotes (ppr t) ]
+ go _ = pure ()
-- -------------------------------------------------------------------------
-- Checking Patterns.
@@ -807,7 +973,7 @@ checkLPat msg e@(L l _) = checkPat msg l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
-checkPat _ loc (L l e@(HsVar (L _ c))) args
+checkPat _ loc (L l e@(HsVar _ (L _ c))) args
| isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
| not (null args) && patIsRec c =
patFail (text "Perhaps you intended to use RecursiveDo") l e
@@ -817,7 +983,7 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (L _ (HsApp f e)) args
+checkPat msg loc (L _ (HsApp _ f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
checkPat msg loc (L _ e) []
@@ -831,76 +997,75 @@ checkAPat msg loc e0 = do
pState <- getPState
let opts = options pState
case e0 of
- EWildPat -> return (WildPat placeHolderType)
- HsVar x -> return (VarPat x)
- HsLit (HsStringPrim _ _) -- (#13260)
+ EWildPat _ -> return (WildPat noExt)
+ HsVar _ x -> return (VarPat noExt x)
+ HsLit _ (HsStringPrim _ _) -- (#13260)
-> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
- HsLit l -> return (LitPat l)
+ HsLit _ l -> return (LitPat noExt l)
-- 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
- HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
- NegApp (L l (HsOverLit pos_lit)) _
+ HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing)
+ NegApp _ (L l (HsOverLit _ pos_lit)) _
-> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
- SectionR (L lb (HsVar (L _ bang))) e -- (! x)
+ SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x)
| bang == bang_RDR
- -> do { bang_on <- extension bangPatEnabled
- ; if bang_on then do { e' <- checkLPat msg e
- ; addAnnotation loc AnnBang lb
- ; return (BangPat e') }
- else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
-
- ELazyPat e -> checkLPat msg e >>= (return . LazyPat)
- EAsPat n e -> checkLPat msg e >>= (return . AsPat n)
+ -> do { hintBangPat loc e0
+ ; e' <- checkLPat msg e
+ ; addAnnotation loc AnnBang lb
+ ; return (BangPat noExt e') }
+
+ ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
+ EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
- EViewPat expr patE -> checkLPat msg patE >>=
- (return . (\p -> ViewPat expr p placeHolderType))
- ExprWithTySig e t -> do e <- checkLPat msg e
- return (SigPatIn e t)
+ EViewPat _ expr patE -> checkLPat msg patE >>=
+ (return . (\p -> ViewPat noExt expr p))
+ ExprWithTySig t e -> do e <- checkLPat msg e
+ return (SigPat t e)
-- n+k patterns
- OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
- (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+ OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
+ (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit))
- OpApp l op _fix r -> do l <- checkLPat msg l
- r <- checkLPat msg r
- case op of
- L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
- -> return (ConPatIn (L cl c) (InfixCon l r))
- _ -> patFail msg loc e0
+ OpApp _ l (L cl (HsVar _ (L _ c))) r
+ | isDataOcc (rdrNameOcc c) -> do
+ l <- checkLPat msg l
+ r <- checkLPat msg r
+ return (ConPatIn (L cl c) (InfixCon l r))
+
+ OpApp {} -> patFail msg loc e0
- HsPar e -> checkLPat msg e >>= (return . ParPat)
- ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
- return (ListPat ps placeHolderType Nothing)
- ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es
- return (PArrPat ps placeHolderType)
+ ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
+ return (ListPat noExt ps)
- ExplicitTuple es b
+ HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
+
+ ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
- [e | L _ (Present e) <- es]
- return (TuplePat ps b [])
+ [e | L _ (Present _ e) <- es]
+ return (TuplePat noExt ps b)
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
- ExplicitSum alt arity expr _ -> do
+ ExplicitSum _ alt arity expr -> do
p <- checkLPat msg expr
- return (SumPat p alt arity placeHolderType)
+ return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
- HsSpliceE s | not (isTypedSplice s)
- -> return (SplicePat s)
+ HsSpliceE _ s | not (isTypedSplice s)
+ -> return (SplicePat noExt s)
_ -> patFail msg loc e0
placeHolderPunRhs :: LHsExpr GhcPs
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
+placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -934,14 +1099,14 @@ checkValDef :: SDoc
checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (L (combineLocs lhs sig)
- (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
+ (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
-checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind msg strictness ann (getLoc lhs)
- fun is_infix pats opt_sig (L l grhss)
+ fun is_infix pats (L l grhss)
Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc
@@ -951,18 +1116,19 @@ checkFunBind :: SDoc
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
- -> Maybe (LHsType GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
= do ps <- checkPatterns msg 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
- [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
+ [L match_span (Match { m_ext = noExt
+ , m_ctxt = FunRhs { mc_fun = fun
+ , mc_fixity = is_infix
+ , mc_strictness = strictness }
, m_pats = ps
- , m_type = opt_sig
, m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
@@ -971,10 +1137,10 @@ makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn ms
- = FunBind { fun_id = fn,
+ = FunBind { fun_ext = noExt,
+ fun_id = fn,
fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper,
- bind_fvs = placeHolderNames,
fun_tick = [] }
checkPatBind :: SDoc
@@ -983,11 +1149,11 @@ checkPatBind :: SDoc
-> P ([AddAnn],HsBind GhcPs)
checkPatBind msg lhs (L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
- ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
+ ; return ([],PatBind noExt lhs grhss
([],[])) }
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
| isUnqual v
, not (isDataOcc (rdrNameOcc v))
= return lrdr
@@ -1009,9 +1175,9 @@ checkValSigLhs lhs@(L l _)
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
- looks_like s (L _ (HsVar (L _ v))) = v == s
- looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
- looks_like _ _ = False
+ 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")
default_RDR = mkUnqual varName (fsLit "default")
@@ -1044,13 +1210,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
-- not be any OpApps inside the e's
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
-- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
- | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
+splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
+ | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
where
l' = combineLocs bang arg1
(arg1,argns) = split_bang r_arg []
- split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
- split_bang e es = (e,es)
+ split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
+ split_bang e es = (e,es)
splitBang _ = Nothing
isFunLhs :: LHsExpr GhcPs
@@ -1069,14 +1235,15 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] []
where
- go (L loc (HsVar (L _ f))) es ann
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
- go (L _ (HsApp f e)) es ann = go f (e:es) ann
- go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ go (L loc (HsVar _ (L _ f))) es ann
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
+ go (L _ (HsApp _ f e)) es ann = go f (e:es) ann
+ go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
-- Things of the form `!x` are also FunBinds
- -- See Note [Varieties of binding pattern matches]
- go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+ -- See Note [FunBind vs PatBind]
+ go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
+ [] ann
| bang == bang_RDR
, not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
@@ -1093,7 +1260,7 @@ isFunLhs e = go e [] []
-- ToDo: what about this?
-- x + 1 `op` y = ...
- go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
+ go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es) ann
@@ -1107,59 +1274,83 @@ isFunLhs e = go e [] []
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
- op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
+ op_app = L loc (OpApp noExt k
+ (L loc' (HsVar noExt (L loc' op))) r)
_ -> return Nothing }
go _ _ _ = return Nothing
-
--- | Transform btype_no_ops with strict_mark's into HsEqTy's
--- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
-splitTilde :: LHsType GhcPs -> P (LHsType GhcPs)
-splitTilde t = go t
- where go (L loc (HsAppTy t1 t2))
- | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
- <- t2
- = do
- moveAnnotations lo loc
- t1' <- go t1
- return (L loc (HsEqTy t1' t2'))
- | otherwise
- = do
- t1' <- go t1
- case t1' of
- (L lo (HsEqTy tl tr)) -> do
- let lr = combineLocs tr t2
- moveAnnotations lo loc
- return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
- t -> do
- return (L loc (HsAppTy t t2))
-
- go t = return t
-
-
--- | Transform tyapps with strict_marks into uses of twiddle
--- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
-splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs]
-splitTildeApps [] = return []
-splitTildeApps (t : rest) = do
- rest' <- concatMapM go rest
- return (t : rest')
- where go (L l (HsAppPrefix
- (L loc (HsBangTy
- (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
- ty))))
- = addAnnotation l AnnTilde tilde_loc >>
- return
- [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
- L l (HsAppPrefix ty)]
- -- NOTE: no annotation is attached to an HsAppPrefix, so the
- -- surrounding SrcSpan is not critical
- where
- tilde_loc = srcSpanFirstCharacter loc
-
- go t = return [t]
-
-
+-- | Transform a list of 'atype' with 'strict_mark' into
+-- HsOpTy's of 'eqTyCon_RDR':
+--
+-- [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d)
+--
+-- See Note [Parsing ~]
+splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
+splitTilde [] = panic "splitTilde"
+splitTilde (x:xs) = go x xs
+ where
+ -- We accumulate applications in the LHS until we encounter a laziness
+ -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs'
+ -- accumulator will become '(Foo x) y'. Then we strip the laziness
+ -- annotation off 'Bar' and process the tail [Bar, z] recursively.
+ --
+ -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'.
+ -- In case the tail contained more laziness annotations, they would be
+ -- processed similarly. This makes '~' right-associative.
+ go lhs [] = return lhs
+ go lhs (x:xs)
+ | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
+ = do { rhs <- splitTilde (t:xs)
+ ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
+ ; moveAnnotations loc (getLoc r)
+ ; return r }
+ | otherwise
+ = go (mkHsAppTy lhs x) xs
+
+ tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
+
+-- | Either an operator or an operand.
+data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
+
+-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
+-- into a type.
+--
+-- User input: @F x y + G a b * X@
+-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
+-- Output corresponds to what the user wrote assuming all operators are of the
+-- same fixity and right-associative.
+--
+-- It's a bit silly that we're doing it at all, as the renamer will have to
+-- rearrange this, and it'd be easier to keep things separate.
+mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
+mergeOps = go [] id
+ where
+ -- clause (a):
+ -- when we encounter an operator, we must have accumulated
+ -- something for its rhs, and there must be something left
+ -- to build its lhs.
+ go acc ops_acc (L l (TyElOpr op):xs) =
+ if null acc || null xs
+ then failOpFewArgs (L l op)
+ else do { a <- splitTilde acc
+ ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+
+ -- clause (b):
+ -- whenever an operand is encountered, it is added to the accumulator
+ go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
+
+ -- clause (c):
+ -- at this point we know that 'acc' is non-empty because
+ -- there are three options when 'acc' can be empty:
+ -- 1. 'mergeOps' was called with an empty list, and this
+ -- should never happen
+ -- 2. 'mergeOps' was called with a list where the head is an
+ -- operator, this is handled by clause (a)
+ -- 3. 'mergeOps' was called with a list where the head is an
+ -- operand, this is handled by clause (b)
+ go acc ops_acc [] =
+ do { a <- splitTilde acc
+ ; return (ops_acc a) }
---------------------------------------------------------------------------
-- Check for monad comprehensions
@@ -1187,34 +1378,35 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap f (L l a) = f l a >>= (\b -> return $ L l b)
checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
-checkCmd _ (HsArrApp e1 e2 ptt haat b) =
- return $ HsCmdArrApp e1 e2 ptt haat b
-checkCmd _ (HsArrForm e mf args) =
- return $ HsCmdArrForm e Prefix mf args
-checkCmd _ (HsApp e1 e2) =
- checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
-checkCmd _ (HsLam mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
-checkCmd _ (HsPar e) =
- checkCommand e >>= (\c -> return $ HsCmdPar c)
-checkCmd _ (HsCase e mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
-checkCmd _ (HsIf cf ep et ee) = do
+checkCmd _ (HsArrApp _ e1 e2 haat b) =
+ return $ HsCmdArrApp noExt e1 e2 haat b
+checkCmd _ (HsArrForm _ e mf args) =
+ return $ HsCmdArrForm noExt e Prefix mf args
+checkCmd _ (HsApp _ e1 e2) =
+ checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
+checkCmd _ (HsLam _ mg) =
+ checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
+checkCmd _ (HsPar _ e) =
+ checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
+checkCmd _ (HsCase _ e mg) =
+ checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
+checkCmd _ (HsIf _ cf ep et ee) = do
pt <- checkCommand et
pe <- checkCommand ee
- return $ HsCmdIf cf ep pt pe
-checkCmd _ (HsLet lb e) =
- checkCommand e >>= (\c -> return $ HsCmdLet lb c)
-checkCmd _ (HsDo DoExpr (L l stmts) ty) =
- mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
-
-checkCmd _ (OpApp eLeft op _fixity eRight) = do
+ return $ HsCmdIf noExt cf ep pt pe
+checkCmd _ (HsLet _ lb e) =
+ checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
+checkCmd _ (HsDo _ DoExpr (L l stmts)) =
+ mapM checkCmdLStmt stmts >>=
+ (\ss -> return $ HsCmdDo noExt (L l ss) )
+
+checkCmd _ (OpApp _ eLeft op eRight) = do
-- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
c1 <- checkCommand eLeft
c2 <- checkCommand eRight
- let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
- arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
- return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
+ let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
+ arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+ return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
checkCmd l e = cmdFail l e
@@ -1222,39 +1414,44 @@ checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
checkCmdLStmt = locMap checkCmdStmt
checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
-checkCmdStmt _ (LastStmt e s r) =
- checkCommand e >>= (\c -> return $ LastStmt c s r)
-checkCmdStmt _ (BindStmt pat e b f t) =
- checkCommand e >>= (\c -> return $ BindStmt pat c b f t)
-checkCmdStmt _ (BodyStmt e t g ty) =
- checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
-checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
+checkCmdStmt _ (LastStmt x e s r) =
+ checkCommand e >>= (\c -> return $ LastStmt x c s r)
+checkCmdStmt _ (BindStmt x pat e b f) =
+ checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
+checkCmdStmt _ (BodyStmt x e t g) =
+ checkCommand e >>= (\c -> return $ BodyStmt x c t g)
+checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
ss <- mapM checkCmdLStmt stmts
- return $ stmt { recS_stmts = ss }
+ return $ stmt { recS_ext = noExt, recS_stmts = ss }
+checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
checkCmdStmt l stmt = cmdStmtFail l stmt
checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
-> P (MatchGroup GhcPs (LHsCmd GhcPs))
checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
ms' <- mapM (locMap $ const convert) ms
- return $ mg { mg_alts = L l ms' }
- where convert (Match mf pat mty grhss) = do
+ return $ mg { mg_ext = noExt, mg_alts = L l ms' }
+ where convert match@(Match { m_grhss = grhss }) = do
grhss' <- checkCmdGRHSs grhss
- return $ Match mf pat mty grhss'
+ return $ match { m_ext = noExt, m_grhss = grhss'}
+ convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
+checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
-checkCmdGRHSs (GRHSs grhss binds) = do
+checkCmdGRHSs (GRHSs x grhss binds) = do
grhss' <- mapM checkCmdGRHS grhss
- return $ GRHSs grhss' binds
+ return $ GRHSs x grhss' binds
+checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
checkCmdGRHS = locMap $ const convert
where
- convert (GRHS stmts e) = do
+ convert (GRHS x stmts e) = do
c <- checkCommand e
-- cmdStmts <- mapM checkCmdLStmt stmts
- return $ GRHS {- cmdStmts -} stmts c
+ return $ GRHS x {- cmdStmts -} stmts c
+ convert (XGRHS _) = panic "checkCmdGRHS"
cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
@@ -1278,7 +1475,7 @@ mkRecConstrOrUpdate
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
-> P (HsExpr GhcPs)
-mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
| isRdrDataCon c
= return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
@@ -1287,23 +1484,23 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
mkRdrRecordUpd exp flds
- = RecordUpd { rupd_expr = exp
- , rupd_flds = flds
- , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
- , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
+ = RecordUpd { rupd_ext = noExt
+ , rupd_expr = exp
+ , rupd_flds = flds }
mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
- = RecordCon { rcon_con_name = con, rcon_flds = flds
- , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+ = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
- = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
+ = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
+ = panic "mk_rec_upd_field"
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -1360,10 +1557,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
- returnSpec spec = return $ ForD $ ForeignImport
- { fd_name = v
+ returnSpec spec = return $ ForD noExt $ ForeignImport
+ { fd_i_ext = noExt
+ , fd_name = v
, fd_sig_ty = ty
- , fd_co = noForeignImportCoercionYet
, fd_fi = spec
}
@@ -1433,9 +1630,8 @@ mkExport :: Located CCallConv
-> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
-> P (HsDecl GhcPs)
mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
- = return $ ForD $
- ForeignExport { fd_name = v, fd_sig_ty = ty
- , fd_co = noForeignExportCoercionYet
+ = return $ ForD noExt $
+ ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
, fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
(L le esrc) }
where
@@ -1468,11 +1664,11 @@ mkModuleImpExp (L l specname) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar (L l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs . L l <$> nameT
- ImpExpAll -> IEThingAll . L l <$> nameT
- ImpExpList xs ->
- (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) [])
+ -> return $ IEVar noExt (L l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs noExt . L l <$> nameT
+ ImpExpAll -> IEThingAll noExt . L l <$> nameT
+ ImpExpList xs ->
+ (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
<$> nameT
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
@@ -1482,7 +1678,8 @@ mkModuleImpExp (L l specname) subs =
pos = maybe NoIEWildcard IEWildcard
(findIndex isImpExpQcWildcard withs)
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
- in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
+ in (\newName
+ -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
else parseErrorSDoc l
(text "Illegal export form (use PatternSynonyms to enable)")
where
@@ -1519,7 +1716,7 @@ mkTypeImpExp name =
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
checkImportSpec ie@(L _ specs) =
- case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
+ case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
@@ -1543,11 +1740,49 @@ isImpExpQcWildcard ImpExpQcWildcard = True
isImpExpQcWildcard _ = False
-----------------------------------------------------------------------------
+-- Warnings and failures
+
+warnStarIsType :: SrcSpan -> P ()
+warnStarIsType span = addWarning Opt_WarnStarIsType span msg
+ where
+ msg = text "Using" <+> quotes (text "*")
+ <+> text "(or its Unicode variant) to mean"
+ <+> quotes (text "Data.Kind.Type")
+ $$ text "relies on the StarIsType extension."
+ $$ text "Suggested fix: use" <+> quotes (text "Type")
+ <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
+
+warnStarBndr :: SrcSpan -> P ()
+warnStarBndr span = addWarning Opt_WarnStarBinder span msg
+ where
+ msg = text "Found binding occurrence of" <+> quotes (text "*")
+ <+> text "yet StarIsType is enabled."
+ $$ text "NB. To use (or export) this operator in"
+ <+> text "modules with StarIsType,"
+ $$ text " including the definition module, you must qualify it."
+
+failOpFewArgs :: Located RdrName -> P a
+failOpFewArgs (L loc op) =
+ do { star_is_type <- extension starIsTypeEnabled
+ ; let msg = too_few $$ starInfo star_is_type op
+ ; parseErrorSDoc loc msg }
+ where
+ too_few = text "Operator applied to too few arguments:" <+> ppr op
+
+-----------------------------------------------------------------------------
-- Misc utils
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc span s = failSpanMsgP span s
+-- | Hint about bang patterns, assuming @BangPatterns@ is off.
+hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat span e = do
+ bang_on <- extension bangPatEnabled
+ unless bang_on $
+ parseErrorSDoc span
+ (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
+
data SumOrTuple
= Sum ConTag Arity (LHsExpr GhcPs)
| Tuple [LHsTupArg GhcPs]
@@ -1555,11 +1790,11 @@ data SumOrTuple
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
-- Tuple
-mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
+mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
-- Sum
mkSumOrTuple Unboxed _ (Sum alt arity e) =
- return (ExplicitSum alt arity e PlaceHolder)
+ return (ExplicitSum noExt alt arity e)
mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
where
@@ -1568,3 +1803,8 @@ mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
ppr_bars n = hsep (replicate n (Outputable.char '|'))
+
+mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
+mkLHsOpTy x op y =
+ let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
+ in L loc (mkHsOpTy x op y)
diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c
index fdaea44cc7..eca3e3d25c 100644
--- a/compiler/parser/cutils.c
+++ b/compiler/parser/cutils.c
@@ -13,23 +13,6 @@ places in the GHC library.
#include <unistd.h>
#endif
-/*
-Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner,
-and causes gcc to require too many registers on x84
-*/
-
-HsInt
-ghc_strlen( HsPtr a )
-{
- return (strlen((char *)a));
-}
-
-HsInt
-ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len )
-{
- return (memcmp((char *)a1, a2, len));
-}
-
void
enableTimingStats( void ) /* called from the driver */
{
diff --git a/compiler/parser/cutils.h b/compiler/parser/cutils.h
index 0c8ab12a2c..009fffa86f 100644
--- a/compiler/parser/cutils.h
+++ b/compiler/parser/cutils.h
@@ -6,10 +6,5 @@
#include "HsFFI.h"
-// Out-of-line string functions, see compiler/utils/FastString.hs
-HsInt ghc_strlen( HsAddr a );
-HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len );
-
-
void enableTimingStats( void );
void setHeapSize( HsInt size );
View Lorry Controller Status