[project @ 2003-09-10 16:44:03 by simonmar]

New flags for individual syntax extensions:

  -fth                enables template haskell
  -fimplicit-params   enables implicit parameters

These extensions are still implied by -fglasgow-exts, but they can now
be switched off individually with -fno-th and -fno-implicit-params
respectively.  Also, -fno-ffi now works as expected.

I cleaned up the interface to the lexer a bit while I was here.

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 6cf2f3d..2d0718b 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -293,6 +293,8 @@ data DynFlag
    | Opt_PArr                         -- syntactic support for parallel arrays
    | Opt_With                         -- deprecated keyword for implicit parms
    | Opt_Arrows                               -- Arrow-notation syntax
+   | Opt_TH
+   | Opt_ImplicitParams
    | Opt_Generics
    | Opt_NoImplicitPrelude 
 

diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 1189f10..337cad7 100644 (file)
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.123 2003/09/04 11:08:47 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.124 2003/09/10 16:44:05 simonmar Exp $
 --
 -- Driver flags
 --
@@ -424,6 +424,9 @@ dynamic_flags = [
   ,  ( "fvia-C",       NoArg (setLang HscC) )
   ,  ( "filx",         NoArg (setLang HscILX) )
 
+  ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
+  ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
+
        -- "active negatives"
   ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
   ,  ( "fno-monomorphism-restriction", 
@@ -451,18 +454,21 @@ fFlags = [
   ( "warn-unused-imports",             Opt_WarnUnusedImports ),
   ( "warn-unused-matches",             Opt_WarnUnusedMatches ),
   ( "warn-deprecations",               Opt_WarnDeprecations ),
-  ( "glasgow-exts",                    Opt_GlasgowExts ),
   ( "fi",                              Opt_FFI ),  -- support `-ffi'...
   ( "ffi",                             Opt_FFI ),  -- ...and also `-fffi'
   ( "with",                            Opt_With ), -- with keyword
   ( "arrows",                          Opt_Arrows ), -- arrow syntax
   ( "parr",                            Opt_PArr ),
+  ( "th",                              Opt_TH ),
+  ( "implicit-params",                 Opt_ImplicitParams ),
   ( "allow-overlapping-instances",     Opt_AllowOverlappingInstances ),
   ( "allow-undecidable-instances",     Opt_AllowUndecidableInstances ),
   ( "allow-incoherent-instances",      Opt_AllowIncoherentInstances ),
   ( "generics",                        Opt_Generics )
   ]
 
+glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ]
+
 isFFlag f = f `elem` (map fst fFlags)
 getFFlag f = fromJust (lookup f fFlags)
 

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 02465bf..ed6f405 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -38,8 +38,7 @@ import HsSyn
 import RdrName         ( nameRdrName )
 import StringBuffer    ( hGetStringBuffer )
 import Parser
-import Lexer           ( P(..), ParseResult(..), ExtFlags(..), 
-                         mkPState, showPFailed )
+import Lexer           ( P(..), ParseResult(..), mkPState, showPFailed )
 import SrcLoc          ( mkSrcLoc )
 import TcRnDriver      ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
 import RnEnv           ( extendOrigNameCache )
@@ -388,10 +387,9 @@ myParseModule dflags src_filename
       _scc_  "Parser" do
       buf <- hGetStringBuffer src_filename
 
-      let exts = mkExtFlags dflags
-         loc  = mkSrcLoc (mkFastString src_filename) 1 0
+      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 
-      case unP parseModule (mkPState buf loc exts) of {
+      case unP parseModule (mkPState buf loc dflags) of {
 
        PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
                                  return Nothing };
@@ -510,10 +508,9 @@ hscParseStmt dflags str
 
       buf <- stringToStringBuffer str
 
-      let exts = mkExtFlags dflags 
-         loc  = mkSrcLoc FSLIT("<interactive>") 1 0
+      let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 
-      case unP parseStmt (mkPState buf loc exts) of {
+      case unP parseStmt (mkPState buf loc dflags) of {
 
        PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);     
                                   return Nothing };
@@ -566,10 +563,8 @@ hscThing hsc_env pcs0 ic str
 myParseIdentifier dflags str
   = do buf <- stringToStringBuffer str
  
-       let exts = mkExtFlags dflags
-          loc  = mkSrcLoc FSLIT("<interactive>") 1 0
-
-       case unP parseIdentifier (mkPState buf loc exts) of
+       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
+       case unP parseIdentifier (mkPState buf loc dflags) of
 
          PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
                                     return Nothing }
@@ -670,11 +665,4 @@ initExternalPackageState
 
 initOrigNames :: OrigNameCache
 initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames 
-
-mkExtFlags dflags
-  = ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
-              ffiEF         = dopt Opt_FFI      dflags,
-              withEF        = dopt Opt_With     dflags,
-              arrowsEF      = dopt Opt_Arrows   dflags,
-              parrEF        = dopt Opt_PArr     dflags}
 \end{code}

diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y
index 62813d3..cfecbca 100644 (file)
--- a/ghc/compiler/main/ParsePkgConf.y
+++ b/ghc/compiler/main/ParsePkgConf.y
@@ -5,6 +5,7 @@ module ParsePkgConf( loadPackageConfig ) where
 
 import Packages  ( PackageConfig(..), defaultPackageConfig )
 import Lexer
+import CmdLineOpts
 import FastString
 import StringBuffer
 import SrcLoc
@@ -96,12 +97,7 @@ loadPackageConfig :: FilePath -> IO [PackageConfig]
 loadPackageConfig conf_filename = do
    buf <- hGetStringBuffer conf_filename
    let loc  = mkSrcLoc (mkFastString conf_filename) 1 0
-       exts = ExtFlags {glasgowExtsEF = False,
-                       ffiEF         = False,
-                       arrowsEF      = False,
-                       withEF        = False,
-                       parrEF        = False}
-   case unP parse (mkPState buf loc exts) of
+   case unP parse (mkPState buf loc defaultDynFlags) of
        PFailed l1 l2 err -> do
             throwDyn (InstallationError (showPFailed l1 l2 err))
 

diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x
index 344f0c4..0bff597 100644 (file)
--- a/ghc/compiler/parser/Lexer.x
+++ b/ghc/compiler/parser/Lexer.x
@@ -22,7 +22,7 @@
 
 {
 module Lexer (
-   Token(..), Token__(..), lexer, ExtFlags(..), mkPState, showPFailed,
+   Token(..), Token__(..), lexer, mkPState, showPFailed,
    P(..), ParseResult(..), setSrcLocFor, getSrcLoc, 
    failMsgP, failLocMsgP, srcParseFail,
    popContext, pushCurrentContext,
@@ -38,6 +38,7 @@ import FastString
 import FastTypes
 import SrcLoc
 import UniqFM
+import CmdLineOpts
 import Ctype
 import Util            ( maybePrefixMatch )
 
@@ -185,27 +186,40 @@ $white_no_nl+                             ;
 
 -- "special" symbols
 
+<0,glaexts> {
+  "[:" / { ifExtension parrEnabled }   { token ITopabrack }
+  ":]" / { ifExtension parrEnabled }   { token ITcpabrack }
+}
+  
+<0,glaexts> {
+  "[|"     / { ifExtension thEnabled } { token ITopenExpQuote }
+  "[e|"            / { ifExtension thEnabled } { token ITopenExpQuote }
+  "[p|"            / { ifExtension thEnabled } { token ITopenPatQuote }
+  "[d|"            / { ifExtension thEnabled } { layout_token ITopenDecQuote }
+  "[t|"            / { ifExtension thEnabled } { token ITopenTypQuote }
+  "|]"     / { ifExtension thEnabled } { token ITcloseQuote }
+  \$ @varid / { ifExtension thEnabled }        { skip_one_varid ITidEscape }
+  "$("     / { ifExtension thEnabled } { token ITparenEscape }
+}
+
+<0,glaexts> {
+  "(|" / { ifExtension arrowsEnabled }  { special IToparenbar }
+  "|)" / { ifExtension arrowsEnabled }  { special ITcparenbar }
+}
+
+<0,glaexts> {
+  \? @varid / { ifExtension ipEnabled }        { skip_one_varid ITdupipvarid }
+  \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }
+}
+
 <glaexts> {
   "(#"                                 { token IToubxparen }
   "#)"                                 { token ITcubxparen }
-  
-  "[:"                                 { token ITopabrack }
-  ":]"                                 { token ITcpabrack }
-  
   "{|"                                 { token ITocurlybar }
   "|}"                                 { token ITccurlybar }
-  
-  "[|"                                 { token ITopenExpQuote }
-  "[e|"                                        { token ITopenExpQuote }
-  "[p|"                                        { token ITopenPatQuote }
-  "[d|"                                        { layout_token ITopenDecQuote }
-  "[t|"                                        { token ITopenTypQuote }
-  "|]"                                 { token ITcloseQuote }
 }
 
 <0,glaexts> {
-  "(|" / { \b _ _ _ -> arrowsEnabled b} { special IToparenbar }
-  "|)" / { \b _ _ _ -> arrowsEnabled b} { special ITcparenbar }
   \(                                   { special IToparen }
   \)                                   { special ITcparen }
   \[                                   { special ITobrack }
@@ -218,13 +232,6 @@ $white_no_nl+                              ;
   \}                                   { close_brace }
 }
 
-<glaexts> {
-  \? @varid                    { skip_one_varid ITdupipvarid }
-  \% @varid                    { skip_one_varid ITsplitipvarid }
-  \$ @varid                    { skip_one_varid ITidEscape }
-  "$("                         { token ITparenEscape }
-}
-
 <0,glaexts> {
   @qual @varid                 { check_qvarid }
   @qual @conid                 { idtoken qconid }
@@ -592,6 +599,8 @@ pop_and act loc end buf len = do popLexState; act loc end buf len
 
 notFollowedBy char _ _ _ (_,buf) = atEnd buf || currentChar buf /= char
 
+ifExtension pred bits _ _ _ = pred bits
+
 {-
   nested comments require traversing by hand, they can't be parsed
   using regular expressions.
@@ -1198,6 +1207,8 @@ ffiBit       = 1
 parrBit           = 2
 withBit           = 3
 arrowsBit  = 4
+thBit     = 5
+ipBit      = 6
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 glaExtsEnabled flags = testBit flags glaExtsBit
@@ -1205,23 +1216,13 @@ ffiEnabled     flags = testBit flags ffiBit
 withEnabled    flags = testBit flags withBit
 parrEnabled    flags = testBit flags parrBit
 arrowsEnabled  flags = testBit flags arrowsBit
-
--- convenient record-based bitmap for the interface to the rest of the world
---
--- NB: `glasgowExtsEF' implies `ffiEF' (see `mkPState' below)
---
-data ExtFlags = ExtFlags {
-                 glasgowExtsEF :: Bool,
-                 ffiEF         :: Bool,
-                 withEF        :: Bool,
-                 parrEF        :: Bool,
-                 arrowsEF      :: Bool
-               }
+thEnabled      flags = testBit flags thBit
+ipEnabled      flags = testBit flags ipBit
 
 -- create a parse state
 --
-mkPState :: StringBuffer -> SrcLoc -> ExtFlags -> PState
-mkPState buf loc exts  = 
+mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
+mkPState buf loc flags  = 
   PState {
       buffer    = buf,
       last_loc   = loc,
@@ -1233,12 +1234,13 @@ mkPState buf loc exts  =
        -- we begin in the layout state if toplev_layout is set
     }
     where
-      bitmap =     glaExtsBit `setBitIf` glasgowExtsEF     exts
-              .|. ffiBit     `setBitIf` (ffiEF            exts
-                                         || glasgowExtsEF exts)
-              .|. withBit    `setBitIf` withEF            exts
-              .|. parrBit    `setBitIf` parrEF            exts
-              .|. arrowsBit  `setBitIf` arrowsEF          exts
+      bitmap =     glaExtsBit `setBitIf` dopt Opt_GlasgowExts flags
+              .|. ffiBit     `setBitIf` dopt Opt_FFI         flags
+              .|. withBit    `setBitIf` dopt Opt_With        flags
+              .|. parrBit    `setBitIf` dopt Opt_PArr        flags
+              .|. arrowsBit  `setBitIf` dopt Opt_Arrows      flags
+              .|. thBit      `setBitIf` dopt Opt_TH          flags
+              .|. ipBit      `setBitIf` dopt Opt_ImplicitParams flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b

diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 977b80f..3ef8c26 100644 (file)
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -640,12 +640,13 @@ readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception Par
        -- Just x  <=> successfully found and parsed 
 
 readIface mod file_path is_hi_boot_file
-  = ioToTcRn (tryMost (read_iface mod file_path is_hi_boot_file))
+  = do dflags <- getDOpts
+       ioToTcRn (tryMost (read_iface mod dflags file_path is_hi_boot_file))
 
-read_iface mod file_path is_hi_boot_file
+read_iface mod dflags file_path is_hi_boot_file
  | is_hi_boot_file             -- Read ascii
  = do { buffer <- hGetStringBuffer file_path ;
-        case unP parseIface (mkPState buffer loc exts) of
+        case unP parseIface (mkPState buffer loc dflags) of
          POk _ iface | wanted_mod_name == actual_mod_name
                      -> return iface
                      | otherwise
@@ -664,11 +665,6 @@ read_iface mod file_path is_hi_boot_file
  = readBinIface file_path
 
  where
-    exts = ExtFlags {glasgowExtsEF = True,
-                    ffiEF         = True,
-                    arrowsEF      = True,
-                    withEF        = True,
-                    parrEF        = True}
     loc  = mkSrcLoc (mkFastString file_path) 1 0
 \end{code}