{
-- 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 #-}
-- 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 }
}
| ITdynamic
| ITsafe
| ITthreadsafe
+ | ITinterruptible
| ITunsafe
| ITstdcallconv
| ITccallconv
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
recBit = 22 -- rec
alternativeLayoutRuleBit :: Int
alternativeLayoutRuleBit = 23
+relaxedLayoutBit :: Int
+relaxedLayoutBit = 24
+nondecreasingIndentationBit :: Int
+nondecreasingIndentationBit = 25
always :: Int -> Bool
always _ = True
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_justClosedExplicitLetBlock = False
}
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_PArr flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows 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
+ .|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators 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),
projects / ghc-hetmet.git / blobdiff