[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.

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 
 

ghc/compiler/main/DriverFlags.hs

 -----------------------------------------------------------------------------
--- $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)
 

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}

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))
 

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

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}