import Control.Monad
import Data.Bits
-import Data.Char ( chr, isSpace )
+import Data.Char ( chr, ord, isSpace )
import Data.Ratio
import Debug.Trace
"|]" / { ifExtension thEnabled } { token ITcloseQuote }
\$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
+
+ "[$" @varid "|" / { ifExtension qqEnabled }
+ { lex_quasiquote_tok }
}
<0> {
| ITdotnet
| ITmdo
| ITfamily
+ | ITgroup
+ | ITby
+ | ITusing
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
+ | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
isSpecial ITfamily = True
+isSpecial ITgroup = True
+isSpecial ITby = True
+isSpecial ITusing = True
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
( "where", ITwhere, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
- ( "forall", ITforall, bit explicitForallBit),
+ ( "forall", ITforall, bit explicitForallBit),
( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
+ ( "group", ITgroup, bit transformComprehensionsBit),
+ ( "by", ITby, bit transformComprehensionsBit),
+ ( "using", ITusing, bit transformComprehensionsBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
Just (c,i) -> do setInput i; return c
-- -----------------------------------------------------------------------------
+-- QuasiQuote
+
+lex_quasiquote_tok :: Action
+lex_quasiquote_tok span buf len = do
+ let quoter = reverse $ takeWhile (/= '$')
+ $ reverse $ lexemeToString buf (len - 1)
+ quoteStart <- getSrcLoc
+ quote <- lex_quasiquote ""
+ end <- getSrcLoc
+ return (L (mkSrcSpan (srcSpanStart span) end)
+ (ITquasiQuote (mkFastString quoter,
+ mkFastString (reverse quote),
+ mkSrcSpan quoteStart end)))
+
+lex_quasiquote :: String -> P String
+lex_quasiquote s = do
+ i <- getInput
+ case alexGetChar' i of
+ Nothing -> lit_error
+
+ Just ('\\',i)
+ | Just ('|',i) <- next -> do
+ setInput i; lex_quasiquote ('|' : s)
+ | Just (']',i) <- next -> do
+ setInput i; lex_quasiquote (']' : s)
+ where next = alexGetChar' i
+
+ Just ('|',i)
+ | Just (']',i) <- next -> do
+ setInput i; return s
+ where next = alexGetChar' i
+
+ Just (c, i) -> do
+ setInput i; lex_quasiquote (c : s)
+
+-- -----------------------------------------------------------------------------
-- Warnings
warn :: DynFlag -> SDoc -> Action
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit = 15 -- (# and #)
standaloneDerivingBit = 16 -- standalone instance deriving declarations
+transformComprehensionsBit = 17
+qqBit = 18 -- enable quasiquoting
genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
always _ = True
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
+transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
+qqEnabled flags = testBit flags qqBit
-- PState for parsing options pragmas
--
.|. 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_ScopedTypeVariables flags
.|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents 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
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b