Add quasi-quotation, courtesy of Geoffrey Mainland

[ghc-hetmet.git] / compiler / parser / Lexer.x

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 47fd107..84ee57e 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -55,7 +55,7 @@ import Util           ( maybePrefixMatch, readRational )
 
 import Control.Monad
 import Data.Bits
-import Data.Char       ( chr, isSpace )
+import Data.Char       ( chr, ord, isSpace )
 import Data.Ratio
 import Debug.Trace
 
@@ -149,7 +149,7 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
 -- have a Haddock comment). The rules then munch the rest of the line.
 
-"-- " ~$docsym .* ;
+"-- " ~[$docsym \#] .* ;
 "--" [^$symbol : \ ] .* ;
 
 -- Next, match Haddock comments if no -haddock flag
@@ -257,9 +257,6 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
 
-  "{-#" $whitechar* (DOC_OPTIONS|doc_options)
-  / { ifExtension haddockEnabled }     { lex_string_prag ITdocOptions }
-
  "{-#"                                 { nested_comment lexToken }
 
   -- ToDo: should only be valid inside a pragma:
@@ -267,11 +264,18 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 }
 
 <option_prags> {
-  "{-#" $whitechar* (OPTIONS|options)   { lex_string_prag IToptions_prag }
-  "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
+  "{-#"  $whitechar* (OPTIONS|options)   { lex_string_prag IToptions_prag }
+  "{-#"  $whitechar* (OPTIONS_GHC|options_ghc)
                                         { lex_string_prag IToptions_prag }
-  "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
-  "{-#" $whitechar* (INCLUDE|include)   { lex_string_prag ITinclude_prag }
+  "{-#"  $whitechar* (OPTIONS_HADDOCK|options_haddock)
+                                         { lex_string_prag ITdocOptions }
+  "-- #"                                 { multiline_doc_comment }
+  "{-#"  $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
+  "{-#"  $whitechar* (INCLUDE|include)   { lex_string_prag ITinclude_prag }
+}
+
+<0> {
+  "-- #" .* ;
 }
 
 <0,option_prags> {
@@ -284,8 +288,8 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 -- Haddock comments
 
 <0> {
-  "-- " $docsym    / { ifExtension haddockEnabled } { multiline_doc_comment }
-  "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
+  "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
+  "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
 }
 
 -- "special" symbols
@@ -304,6 +308,9 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   "|]"     / { ifExtension thEnabled } { token ITcloseQuote }
   \$ @varid / { ifExtension thEnabled }        { skip_one_varid ITidEscape }
   "$("     / { ifExtension thEnabled } { token ITparenEscape }
+
+  "[$" @varid "|"  / { ifExtension qqEnabled }
+                     { lex_quasiquote_tok }
 }
 
 <0> {
@@ -446,6 +453,9 @@ data Token
   | ITdotnet
   | ITmdo
   | ITfamily
+  | ITgroup
+  | ITby
+  | ITusing
 
        -- Pragmas
   | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE
@@ -535,6 +545,7 @@ data Token
   | ITparenEscape              --  $( 
   | ITvarQuote                 --  '
   | ITtyQuote                  --  ''
+  | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
 
   -- Arrow notation extension
   | ITproc
@@ -555,6 +566,7 @@ data Token
   | ITdocCommentNamed String     -- something beginning '-- $'
   | ITdocSection      Int String -- a section heading
   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
+  | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
 
 #ifdef DEBUG
   deriving Show -- debugging
@@ -578,6 +590,9 @@ isSpecial ITccallconv   = True
 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
@@ -616,9 +631,12 @@ reservedWordsFM = listToUFM $
        ( "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),
@@ -819,7 +837,8 @@ withLexedDocType lexDocComment = do
     '|' -> lexDocComment input ITdocCommentNext False
     '^' -> lexDocComment input ITdocCommentPrev False
     '$' -> lexDocComment input ITdocCommentNamed False
-    '*' -> lexDocSection 1 input 
+    '*' -> lexDocSection 1 input
+    '#' -> lexDocComment input ITdocOptionsOld False
  where 
     lexDocSection n input = case alexGetChar input of 
       Just ('*', input) -> lexDocSection (n+1) input
@@ -1303,6 +1322,42 @@ getCharOrFail =  do
        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
@@ -1504,6 +1559,8 @@ recursiveDoBit = 13 -- mdo
 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
@@ -1523,6 +1580,8 @@ recursiveDoEnabled flags = testBit flags recursiveDoBit
 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
 --
@@ -1569,6 +1628,7 @@ mkPState buf loc 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_ScopedTypeVariables flags
               .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
@@ -1584,6 +1644,7 @@ mkPState buf loc 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