From: Ian Lynagh <igloo@earth.li>
Date: Sat, 24 Jul 2010 23:01:21 +0000 (+0000)
Subject: Add support for Haskell98 and Haskell2010 "languages"
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=0e6ff027979263c36703f26da836a784fe1606a2

Add support for Haskell98 and Haskell2010 "languages"
---

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index afe6652..8b35821 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -45,7 +45,7 @@ module DynFlags (
         parseDynamicNoPackageFlags,
         allFlags,
 
-        supportedExtensions, extensionOptions,
+        supportedLanguagesAndExtensions,
 
         -- ** DynFlag C compiler options
         machdepCCOpts, picCCOpts,
@@ -272,6 +272,8 @@ data DynFlag
 
    deriving (Eq, Show)
 
+data Language = Haskell98 | Haskell2010
+
 data ExtensionFlag
    = Opt_Cpp
    | Opt_OverlappingInstances
@@ -477,6 +479,7 @@ data DynFlags = DynFlags {
 
   -- hsc dynamic flags
   flags                 :: [DynFlag],
+  language              :: Maybe Language,
   extensionFlags        :: Either [OnOff ExtensionFlag]
                                   [ExtensionFlag],
 
@@ -730,6 +733,7 @@ defaultDynFlags =
                     -- The default -O0 options
             ++ standardWarnings,
 
+        language = Nothing,
         extensionFlags = Left [],
 
         log_action = \severity srcSpan style msg ->
@@ -763,7 +767,7 @@ flattenExtensionFlags dflags
     = case extensionFlags dflags of
       Left onoffs ->
           dflags {
-              extensionFlags = Right $ flattenExtensionFlags' onoffs
+              extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
           }
       Right _ ->
           panic "Flattening already-flattened extension flags"
@@ -773,27 +777,39 @@ ensureFlattenedExtensionFlags dflags
     = case extensionFlags dflags of
       Left onoffs ->
           dflags {
-              extensionFlags = Right $ flattenExtensionFlags' onoffs
+              extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
           }
       Right _ ->
           dflags
 
 -- OnOffs accumulate in reverse order, so we use foldr in order to
 -- process them in the right order
-flattenExtensionFlags' :: [OnOff ExtensionFlag] -> [ExtensionFlag]
-flattenExtensionFlags' = foldr f defaultExtensionFlags
+flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag]
+                       -> [ExtensionFlag]
+flattenExtensionFlags' ml = foldr f defaultExtensionFlags
     where f (On f)  flags = f : delete f flags
           f (Off f) flags =     delete f flags
-          defaultExtensionFlags = [
-            Opt_MonoPatBinds,   -- Experimentally, I'm making this non-standard
-                                -- behaviour the default, to see if anyone notices
-                                -- SLPJ July 06
-
-            Opt_ImplicitPrelude,
-            Opt_MonomorphismRestriction,
-            Opt_NPlusKPatterns,
-            Opt_DatatypeContexts
-            ]
+          defaultExtensionFlags = languageExtensions ml
+
+languageExtensions :: Maybe Language -> [ExtensionFlag]
+languageExtensions Nothing
+    = Opt_MonoPatBinds   -- Experimentally, I'm making this non-standard
+                         -- behaviour the default, to see if anyone notices
+                         -- SLPJ July 06
+    : languageExtensions (Just Haskell2010)
+languageExtensions (Just Haskell98)
+    = [Opt_ImplicitPrelude,
+       Opt_MonomorphismRestriction,
+       Opt_NPlusKPatterns,
+       Opt_DatatypeContexts]
+languageExtensions (Just Haskell2010)
+    = [Opt_ImplicitPrelude,
+       Opt_MonomorphismRestriction,
+       Opt_DatatypeContexts,
+       Opt_EmptyDataDecls,
+       Opt_ForeignFunctionInterface,
+       Opt_PatternGuards,
+       Opt_RelaxedPolyRec]
 
 -- The DOpt class is a temporary workaround, to avoid having to do
 -- a mass-renaming dopt->lopt at the moment
@@ -1530,6 +1546,7 @@ dynamic_flags = [
  ++ map (mkFlag False "fno-" unSetExtensionFlag) fLangFlags
  ++ map (mkFlag True  "X"    setExtensionFlag  ) xFlags
  ++ map (mkFlag False "XNo"  unSetExtensionFlag) xFlags
+ ++ map (mkFlag True  "X"    setLanguage  ) languageFlags
 
 package_flags :: [Flag DynP]
 package_flags = [
@@ -1687,12 +1704,21 @@ fLangFlags = [
     deprecatedForExtension "IncoherentInstances" )
   ]
 
+supportedLanguages :: [String]
+supportedLanguages = [ name | (name, _, _) <- languageFlags ]
+
 supportedExtensions :: [String]
 supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ]
 
--- This may contain duplicates
-extensionOptions :: [ExtensionFlag]
-extensionOptions = [ langFlag | (_, langFlag, _) <- xFlags ]
+supportedLanguagesAndExtensions :: [String]
+supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions
+
+-- | These -X<blah> flags cannot be reversed with -XNo<blah>
+languageFlags :: [(String, Language, Bool -> Deprecated)]
+languageFlags = [
+  ( "Haskell98",                        Haskell98, const Supported ),
+  ( "Haskell2010",                      Haskell2010, const Supported )
+  ]
 
 -- | These -X<blah> flags can all be reversed with -XNo<blah>
 xFlags :: [(String, ExtensionFlag, Bool -> Deprecated)]
@@ -1923,6 +1949,10 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f)
 unSetDynFlag f = upd (\dfs -> dopt_unset dfs f)
 
 --------------------------
+setLanguage :: Language -> DynP ()
+setLanguage l = upd (\dfs -> dfs { language = Just l })
+
+--------------------------
 setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
 setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f)
                         ; mapM_ setExtensionFlag deps }
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 4c664bd..d21eeac 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -266,7 +266,7 @@ checkExtension (L l ext)
 -- Checks if a given extension is valid, and if so returns
 -- its corresponding flag. Otherwise it throws an exception.
  =  let ext' = unpackFS ext in
-    if ext' `elem` supportedExtensions
+    if ext' `elem` supportedLanguagesAndExtensions
     then L l ("-X"++ext')
     else unsupportedExtnError l ext'
 
@@ -285,7 +285,7 @@ unsupportedExtnError loc unsup =
     mkPlainErrMsg loc $
         text "Unsupported extension: " <> text unsup $$
         if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
-  where suggestions = fuzzyMatch unsup supportedExtensions
+  where suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
diff --git a/ghc/Main.hs b/ghc/Main.hs
index a62663d..3b4d5e0 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -677,7 +677,7 @@ showInfo dflags = do
           flatten (k, FromDynFlags f) = (k, f dflags)
 
 showSupportedExtensions :: IO ()
-showSupportedExtensions = mapM_ putStrLn supportedExtensions
+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
 
 showVersion :: IO ()
 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)