{
-- 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, bangPatEnabled, datatypeContextsEnabled,
addWarning,
+ incrBracketDepth, decrBracketDepth, getParserBrakDepth,
lexTokenStream
) where
-- 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 }
\$ @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
| IToptions_prag String
| ITinclude_prag String
| ITlanguage_prag
+ | ITvect_prag
+ | ITvect_scalar_prag
| ITdotdot -- reserved symbols
| ITcolon
| 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),
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
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
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
-- 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
--
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
- .|. datatypeContextsBit `setBitIf` dopt Opt_DatatypeContexts 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)
oneWordPrags = Map.fromList([("rules", rulePrag),
("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),
("generated", token ITgenerated_prag),
("core", token ITcore_prag),
("unpack", token ITunpack_prag),
- ("ann", token ITann_prag)])
+ ("ann", token ITann_prag),
+ ("vectorize", token ITvect_prag)])
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))])
-
+ ("specialize notinline", token (ITspec_inline_prag False)),
+ ("vectorize scalar", token ITvect_scalar_prag)])
dispatch_pragmas :: Map String Action -> Action
dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
canonical prag' = case prag' of
"noinline" -> "notinline"
"specialise" -> "specialize"
+ "vectorise" -> "vectorize"
"constructorlike" -> "conlike"
_ -> prag'
canon_ws s = unwords (map canonical (words s))
projects / ghc-hetmet.git / blobdiff