{
-- XXX The above flags turn off warnings in the generated code:
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
+ activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
- extension, standaloneDerivingEnabled, bangPatEnabled,
+ extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
+ incrBracketDepth, decrBracketDepth, getParserBrakDepth,
lexTokenStream
) where
import DynFlags
import Module
import Ctype
+import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) )
import Util ( readRational )
import Control.Monad
-- everywhere: skip whitespace and comments
$white_no_nl+ ;
-$tab+ { warn Opt_WarnTabs (text "Tab character") }
+$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") }
-- Everywhere: deal with nested comments. We explicitly rule out
-- pragmas, "{-#", so that we don't accidentally treat them as comments.
-- context if the curly brace is missing.
-- Careful! This stuff is quite delicate.
<layout, layout_do> {
- \{ / { notFollowedBy '-' } { pop_and open_brace }
+ \{ / { notFollowedBy '-' } { hopefully_open_brace }
-- we might encounter {-# here, but {- has been handled already
\n ;
^\# (line)? { begin line_prag1 }
-- Haddock comments
-<0> {
+<0,option_prags> {
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
}
\$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
+-- For backward compatibility, accept the old dollar syntax
+ "[$" @varid "|" / { ifExtension qqEnabled }
+ { lex_quasiquote_tok }
+
"[" @varid "|" / { ifExtension qqEnabled }
{ lex_quasiquote_tok }
}
}
<0> {
+ "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+ { special ITopenBrak }
+ "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak }
+ "~~" / { ifExtension hetMetEnabled } { special ITescape }
+ "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent }
+ "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar }
+}
+
+<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
-- ToDo: - move `var` and (sym) into lexical syntax?
-- - remove backquote from $special?
<0> {
- @qual @varsym / { ifExtension oldQualOps } { idtoken qvarsym }
- @qual @consym / { ifExtension oldQualOps } { idtoken qconsym }
- @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym }
- @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym }
+ @qual @varsym { idtoken qvarsym }
+ @qual @consym { idtoken qconsym }
@varsym { varsym }
@consym { consym }
}
| ITdynamic
| ITsafe
| ITthreadsafe
+ | ITinterruptible
| ITunsafe
| ITstdcallconv
| ITccallconv
| ITusing
-- Pragmas
- | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
- | ITinline_conlike_prag Bool -- same
+ | ITinline_prag InlineSpec RuleMatchInfo
| ITspec_prag -- SPECIALISE
| ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
| ITsource_prag
| ITvocurly
| ITvccurly
| ITobrack
- | ITopabrack -- [:, for parallel arrays with -XParr
- | ITcpabrack -- :], for parallel arrays with -XParr
+ | ITopabrack -- [:, for parallel arrays with -XParallelArrays
+ | ITcpabrack -- :], for parallel arrays with -XParallelArrays
| ITcbrack
| IToparen
| ITcparen
| ITLarrowtail -- -<<
| ITRarrowtail -- >>-
+ -- Heterogeneous Metaprogramming extension
+ | ITopenBrak -- <[
+ | ITcloseBrak -- ]>
+ | ITescape -- ~~
+ | ITescapeDollar -- ~~$
+ | ITdoublePercent -- %%
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
isSpecial ITdynamic = True
isSpecial ITsafe = True
isSpecial ITthreadsafe = True
+isSpecial ITinterruptible = True
isSpecial ITunsafe = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
( "dynamic", ITdynamic, bit ffiBit),
( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove
+ ( "interruptible", ITinterruptible, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
explicitForallEnabled i)
,("→", ITrarrow, unicodeSyntaxEnabled)
,("←", ITlarrow, unicodeSyntaxEnabled)
- ,("⋯", ITdotdot, unicodeSyntaxEnabled)
,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
pop _span _buf _len = do _ <- popLexState
lexToken
+hopefully_open_brace :: Action
+hopefully_open_brace span buf len
+ = do relaxed <- extension relaxedLayout
+ ctx <- getContext
+ (AI l _) <- getInput
+ let offset = srcLocCol l
+ isOK = relaxed ||
+ case ctx of
+ Layout prev_off : _ -> prev_off < offset
+ _ -> True
+ if isOK then pop_and open_brace span buf len
+ else failSpanMsgP span (text "Missing block")
+
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
act span buf len
(AI l _) <- getInput
let offset = srcLocCol l
ctx <- getContext
+ nondecreasing <- extension nondecreasingIndentation
+ let strict' = strict || not nondecreasing
case ctx of
Layout prev_off : _ |
- (strict && prev_off >= offset ||
- not strict && prev_off > offset) -> do
+ (strict' && prev_off >= offset ||
+ not strict' && prev_off > offset) -> do
-- token is indented to the left of the previous context.
-- we must generate a {} sequence now.
pushLexState layout_left
where read i input = do
case alexGetChar' input of
Just (c,input') | is_digit c -> do
- read (i*base + conv c) input'
+ let i' = i*base + conv c
+ if i' > 0x10ffff
+ then setInput input >> lexError "numeric escape sequence out of range"
+ else read i' input'
_other -> do
- if i >= 0 && i <= 0x10FFFF
- then do setInput input; return (chr i)
- else lit_error input
+ setInput input; return (chr i)
+
silly_escape_chars :: [(String, Char)]
silly_escape_chars = [
alr_expecting_ocurly :: Maybe ALRLayout,
-- Have we just had the '}' for a let block? If so, than an 'in'
-- token doesn't need to close anything:
- alr_justClosedExplicitLetBlock :: Bool
+ alr_justClosedExplicitLetBlock :: Bool,
+ code_type_bracket_depth :: Int
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
setSrcLoc :: SrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
+incrBracketDepth :: P ()
+incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) ()
+decrBracketDepth :: P ()
+decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) ()
+getParserBrakDepth :: P Int
+getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
+
getSrcLoc :: P SrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
EnclosingMark -> other_graphic
DecimalNumber -> digit
LetterNumber -> other_graphic
- OtherNumber -> other_graphic
+ OtherNumber -> digit -- see #4373
ConnectorPunctuation -> symbol
DashPunctuation -> symbol
OpenPunctuation -> other_graphic
setInput :: AlexInput -> P ()
setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
+nextIsEOF :: P Bool
+nextIsEOF = do
+ AI _ s <- getInput
+ return $ atEnd s
+
pushLexState :: Int -> P ()
pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
+activeContext :: P Bool
+activeContext = do
+ ctxt <- getALRContext
+ expc <- getAlrExpectingOCurly
+ impt <- implicitTokenPending
+ case (ctxt,expc) of
+ ([],Nothing) -> return impt
+ _other -> return True
+
setAlrLastLoc :: SrcSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
setNextToken :: Located Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
+implicitTokenPending :: P Bool
+implicitTokenPending
+ = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
+ case ts of
+ [] -> POk s False
+ _ -> POk s True
+
popPendingImplicitToken :: P (Maybe (Located Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- for reasons of efficiency, flags indicating language extensions (eg,
--- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
+-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
-- integer
genericsBit :: Int
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit :: Int
unboxedTuplesBit = 15 -- (# and #)
-standaloneDerivingBit :: Int
-standaloneDerivingBit = 16 -- standalone instance deriving declarations
+datatypeContextsBit :: Int
+datatypeContextsBit = 16
transformComprehensionsBit :: Int
transformComprehensionsBit = 17
qqBit :: Int
inRulePragBit = 19
rawTokenStreamBit :: Int
rawTokenStreamBit = 20 -- producing a token stream with all comments included
-newQualOpsBit :: Int
-newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+)
recBit :: Int
recBit = 22 -- rec
alternativeLayoutRuleBit :: Int
alternativeLayoutRuleBit = 23
+relaxedLayoutBit :: Int
+relaxedLayoutBit = 24
+nondecreasingIndentationBit :: Int
+nondecreasingIndentationBit = 25
+hetMetBit :: Int
+hetMetBit = 31
always :: Int -> Bool
always _ = True
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
arrowsEnabled flags = testBit flags arrowsBit
+hetMetEnabled :: Int -> Bool
+hetMetEnabled flags = testBit flags hetMetBit
thEnabled :: Int -> Bool
thEnabled flags = testBit flags thBit
ipEnabled :: Int -> Bool
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled :: Int -> Bool
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
-standaloneDerivingEnabled :: Int -> Bool
-standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
+datatypeContextsEnabled :: Int -> Bool
+datatypeContextsEnabled flags = testBit flags datatypeContextsBit
qqEnabled :: Int -> Bool
qqEnabled flags = testBit flags qqBit
-- inRulePrag :: Int -> Bool
-- inRulePrag flags = testBit flags inRulePragBit
rawTokenStreamEnabled :: Int -> Bool
rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
-newQualOps :: Int -> Bool
-newQualOps flags = testBit flags newQualOpsBit
-oldQualOps :: Int -> Bool
-oldQualOps flags = not (newQualOps flags)
alternativeLayoutRule :: Int -> Bool
alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit
+relaxedLayout :: Int -> Bool
+relaxedLayout flags = testBit flags relaxedLayoutBit
+nondecreasingIndentation :: Int -> Bool
+nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
-- PState for parsing options pragmas
--
pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
-pragState dynflags buf loc =
- PState {
- buffer = buf,
- messages = emptyMessages,
- dflags = dynflags,
- last_loc = mkSrcSpan loc loc,
- last_len = 0,
- loc = loc,
- extsBitmap = 0,
- context = [],
- lex_state = [bol, option_prags, 0],
- alr_pending_implicit_tokens = [],
- alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
- alr_context = [],
- alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
- }
-
+pragState dynflags buf loc = (mkPState dynflags buf loc) {
+ lex_state = [bol, option_prags, 0]
+ }
-- create a parse state
--
-mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
-mkPState buf loc flags =
+mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
extsBitmap = fromIntegral bitmap,
context = [],
lex_state = [bol, 0],
- -- we begin in the layout state if toplev_layout is set
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = noSrcSpan,
alr_context = [],
alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
+ alr_justClosedExplicitLetBlock = False,
+ code_type_bracket_depth = 0
}
where
- bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
- .|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` dopt Opt_PArr flags
- .|. arrowsBit `setBitIf` dopt Opt_Arrows flags
- .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` dopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
+ bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
+ .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` dopt Opt_DoRec flags
- .|. recBit `setBitIf` dopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
- .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
- .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
+ .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
- .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
- .|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags
+ .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False
dflags <- getDynFlags
- let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags
+ let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
newLine = (lastLoc == noSrcSpan)
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
+ -- This next case is to handle a transitional issue:
+ (ITvbar, ALRLayout _ col : ls, _)
+ | newLine && thisCol == col && transitional ->
+ do addWarning Opt_WarnAlternativeLayoutRuleTransitional
+ thisLoc
+ (transitionalAlternativeLayoutWarning
+ "`|' at the same depth as implicit layout block")
+ setALRContext ls
+ setNextToken t
+ -- Note that we use lastLoc, as we may need to close
+ -- more layouts, or give a semicolon
+ return (L lastLoc ITccurly)
(_, ALRLayout _ col : ls, _)
| newLine && thisCol == col ->
do setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
- (u, _, _)
- | isALRopen u ->
- do setALRContext (ALRNoLayout (containsCommas u) False : context)
- return t
+ -- We need to handle close before open, as 'then' is both
+ -- an open and a close
(u, _, _)
| isALRclose u ->
case context of
setNextToken t
return (L thisLoc ITccurly)
ALRNoLayout _ isLet : ls ->
- do setALRContext ls
+ do let ls' = if isALRopen u
+ then ALRNoLayout (containsCommas u) False : ls
+ else ls
+ setALRContext ls'
when isLet $ setJustClosedExplicitLetBlock True
return t
[] ->
- -- XXX This is an error in John's code, but
- -- it looks reachable to me at first glance
- return t
+ do let ls = if isALRopen u
+ then [ALRNoLayout (containsCommas u) False]
+ else ls
+ setALRContext ls
+ -- XXX This is an error in John's code, but
+ -- it looks reachable to me at first glance
+ return t
+ (u, _, _)
+ | isALRopen u ->
+ do setALRContext (ALRNoLayout (containsCommas u) False : context)
+ return t
(ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
isALRopen :: Token -> Bool
isALRopen ITcase = True
isALRopen ITif = True
+isALRopen ITthen = True
isALRopen IToparen = True
isALRopen ITobrack = True
isALRopen ITocurly = True
isALRclose :: Token -> Bool
isALRclose ITof = True
isALRclose ITthen = True
+isALRclose ITelse = True
isALRclose ITcparen = True
isALRclose ITcbrack = True
isALRclose ITccurly = True
lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
- where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream)
+ where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
+ initState = mkPState dflags' buf loc
go = do
ltok <- lexer return
case ltok of
pragmas = options_pragmas ++ ["cfiles", "contract"]
oneWordPrags = Map.fromList([("rules", rulePrag),
- ("inline", token (ITinline_prag True)),
- ("notinline", token (ITinline_prag False)),
+ ("inline", token (ITinline_prag Inline FunLike)),
+ ("inlinable", token (ITinline_prag Inlinable FunLike)),
+ ("inlineable", token (ITinline_prag Inlinable FunLike)),
+ -- Spelling variant
+ ("notinline", token (ITinline_prag NoInline FunLike)),
("specialize", token ITspec_prag),
("source", token ITsource_prag),
("warning", token ITwarning_prag),
("unpack", token ITunpack_prag),
("ann", token ITann_prag)])
-twoWordPrags = Map.fromList([("inline conlike", token (ITinline_conlike_prag True)),
- ("notinline conlike", token (ITinline_conlike_prag False)),
+twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
+ ("notinline conlike", token (ITinline_prag NoInline ConLike)),
("specialize inline", token (ITspec_inline_prag True)),
("specialize notinline", token (ITspec_inline_prag False))])
projects / ghc-hetmet.git / blobdiff