Comments only

[ghc-hetmet.git] / compiler / main / DynFlags.hs

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6818793..8f0faec 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -17,16 +17,12 @@ module DynFlags (
         DynFlag(..),
         ExtensionFlag(..),
         glasgowExtsFlags,
         DynFlag(..),
         ExtensionFlag(..),
         glasgowExtsFlags,

-        flattenExtensionFlags,
-        ensureFlattenedExtensionFlags,

         dopt,
         dopt_set,
         dopt_unset,
         xopt,
         xopt_set,
         xopt_unset,
         dopt,
         dopt_set,
         dopt_unset,
         xopt,
         xopt_set,
         xopt_unset,

-        xopt_set_flattened,
-        xopt_unset_flattened,

         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,
         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,

@@ -192,7 +188,6 @@ data DynFlag
    | Opt_WarnMissingLocalSigs
    | Opt_WarnNameShadowing
    | Opt_WarnOverlappingPatterns
    | Opt_WarnMissingLocalSigs
    | Opt_WarnNameShadowing
    | Opt_WarnOverlappingPatterns

-   | Opt_WarnSimplePatterns

    | Opt_WarnTypeDefaults
    | Opt_WarnMonomorphism
    | Opt_WarnUnusedBinds
    | Opt_WarnTypeDefaults
    | Opt_WarnMonomorphism
    | Opt_WarnUnusedBinds

@@ -203,6 +198,7 @@ data DynFlag
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans

+   | Opt_WarnAutoOrphans

    | Opt_WarnTabs
    | Opt_WarnUnrecognisedPragmas
    | Opt_WarnDodgyForeignImports
    | Opt_WarnTabs
    | Opt_WarnUnrecognisedPragmas
    | Opt_WarnDodgyForeignImports

@@ -270,6 +266,7 @@ data DynFlag
    | Opt_SharedImplib
    | Opt_BuildingCabalPackage
    | Opt_SSE2
    | Opt_SharedImplib
    | Opt_BuildingCabalPackage
    | Opt_SSE2

+   | Opt_GhciSandbox

 
        -- temporary flags
    | Opt_RunCPS
 
        -- temporary flags
    | Opt_RunCPS

@@ -324,6 +321,7 @@ data ExtensionFlag
    | Opt_GADTs
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
    | Opt_GADTs
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse

+   | Opt_RebindableSyntax

 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable

@@ -499,9 +497,13 @@ data DynFlags = DynFlags {
 
   -- hsc dynamic flags
   flags                 :: [DynFlag],
 
   -- hsc dynamic flags
   flags                 :: [DynFlag],

+  -- Don't change this without updating extensionFlags:

   language              :: Maybe Language,
   language              :: Maybe Language,

-  extensionFlags        :: Either [OnOff ExtensionFlag]
-                                  [ExtensionFlag],
+  -- Don't change this without updating extensionFlags:
+  extensions            :: [OnOff ExtensionFlag],
+  -- extensionFlags should always be equal to
+  --     flattenExtensionFlags language extensions
+  extensionFlags        :: [ExtensionFlag],

 
   -- | Message output action: use "ErrUtils" instead of this if you can
   log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
 
   -- | Message output action: use "ErrUtils" instead of this if you can
   log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),

@@ -739,7 +741,8 @@ defaultDynFlags =
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,

-        extensionFlags = Left [],
+        extensions = [],
+        extensionFlags = flattenExtensionFlags Nothing [],

 
         log_action = \severity srcSpan style msg ->
                         case severity of
 
         log_action = \severity srcSpan style msg ->
                         case severity of

@@ -768,48 +771,33 @@ Note [Verbosity levels]
 data OnOff a = On a
              | Off a
 
 data OnOff a = On a
              | Off a
 

-flattenExtensionFlags :: DynFlags -> DynFlags
-flattenExtensionFlags dflags
-    = case extensionFlags dflags of
-      Left onoffs ->
-          dflags {
-              extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
-          }
-      Right _ ->
-          panic "Flattening already-flattened extension flags"
-
-ensureFlattenedExtensionFlags :: DynFlags -> DynFlags
-ensureFlattenedExtensionFlags dflags
-    = case extensionFlags dflags of
-      Left onoffs ->
-          dflags {
-              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
 -- OnOffs accumulate in reverse order, so we use foldr in order to
 -- process them in the right order

-flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag]
-                       -> [ExtensionFlag]
-flattenExtensionFlags' ml = 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 = languageExtensions ml
 
 languageExtensions :: Maybe Language -> [ExtensionFlag]
     where f (On f)  flags = f : delete f flags
           f (Off f) flags =     delete f flags
           defaultExtensionFlags = languageExtensions ml
 
 languageExtensions :: Maybe Language -> [ExtensionFlag]

+

 languageExtensions Nothing
 languageExtensions Nothing

+    -- Nothing => the default case

     = Opt_MonoPatBinds   -- Experimentally, I'm making this non-standard
                          -- behaviour the default, to see if anyone notices
                          -- SLPJ July 06
       -- In due course I'd like Opt_MonoLocalBinds to be on by default
     = Opt_MonoPatBinds   -- Experimentally, I'm making this non-standard
                          -- behaviour the default, to see if anyone notices
                          -- SLPJ July 06
       -- In due course I'd like Opt_MonoLocalBinds to be on by default

+      -- But NB it's implied by GADTs etc

       -- SLPJ September 2010
     : languageExtensions (Just Haskell2010)
       -- SLPJ September 2010
     : languageExtensions (Just Haskell2010)

+

 languageExtensions (Just Haskell98)
     = [Opt_ImplicitPrelude,
        Opt_MonomorphismRestriction,
        Opt_NPlusKPatterns,
        Opt_DatatypeContexts]
 languageExtensions (Just Haskell98)
     = [Opt_ImplicitPrelude,
        Opt_MonomorphismRestriction,
        Opt_NPlusKPatterns,
        Opt_DatatypeContexts]

+

 languageExtensions (Just Haskell2010)
     = [Opt_ImplicitPrelude,
        Opt_MonomorphismRestriction,
 languageExtensions (Just Haskell2010)
     = [Opt_ImplicitPrelude,
        Opt_MonomorphismRestriction,

@@ -834,37 +822,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
 
 -- | Test whether a 'ExtensionFlag' is set
 xopt :: ExtensionFlag -> DynFlags -> Bool
 
 -- | Test whether a 'ExtensionFlag' is set
 xopt :: ExtensionFlag -> DynFlags -> Bool

-xopt f dflags = case extensionFlags dflags of
-                Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening")
-                Right flags -> f `elem` flags
+xopt f dflags = f `elem` extensionFlags dflags

 
 -- | Set a 'ExtensionFlag'
 xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
 
 -- | Set a 'ExtensionFlag'
 xopt_set :: DynFlags -> ExtensionFlag -> DynFlags

-xopt_set dfs f = case extensionFlags dfs of
-                 Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) }
-                 Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening")
-
--- | Set a 'ExtensionFlag'
-xopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_set_flattened dfs f = case extensionFlags dfs of
-                           Left _ ->
-                               panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened")
-                           Right flags ->
-                               dfs { extensionFlags = Right (f : delete f flags) }
+xopt_set dfs f
+    = let onoffs = On f : extensions dfs
+      in dfs { extensions = onoffs,
+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }

 
 -- | Unset a 'ExtensionFlag'
 xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
 
 -- | Unset a 'ExtensionFlag'
 xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags

-xopt_unset dfs f = case extensionFlags dfs of
-                   Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) }
-                   Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening")
+xopt_unset dfs f
+    = let onoffs = Off f : extensions dfs
+      in dfs { extensions = onoffs,
+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }

 
 

--- | Unset a 'ExtensionFlag'
-xopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_unset_flattened dfs f = case extensionFlags dfs of
-                             Left _ ->
-                                 panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
-                             Right flags ->
-                                 dfs { extensionFlags = Right (delete f flags) }
+setLanguage :: Language -> DynP ()
+setLanguage l = upd f
+    where f dfs = let mLang = Just l
+                      oneoffs = extensions dfs
+                  in dfs {
+                         language = mLang,
+                         extensionFlags = flattenExtensionFlags mLang oneoffs
+                     }

 
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
 
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from

@@ -1355,8 +1336,8 @@ dynamic_flags = [
                                        setTarget HscNothing))
   , Flag "fbyte-code"       (NoArg (setTarget HscInterpreted))
   , Flag "fobject-code"     (NoArg (setTarget defaultHscTarget))
                                        setTarget HscNothing))
   , Flag "fbyte-code"       (NoArg (setTarget HscInterpreted))
   , Flag "fobject-code"     (NoArg (setTarget defaultHscTarget))

-  , Flag "fglasgow-exts"    (NoArg enableGlasgowExts)
-  , Flag "fno-glasgow-exts" (NoArg disableGlasgowExts)
+  , Flag "fglasgow-exts"    (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead"))
+  , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead"))

  ]
  ++ map (mkFlag True  "f"    setDynFlag  ) fFlags
  ++ map (mkFlag False "fno-" unSetDynFlag) fFlags
  ]
  ++ map (mkFlag True  "f"    setDynFlag  ) fFlags
  ++ map (mkFlag False "fno-" unSetDynFlag) fFlags

@@ -1432,7 +1413,6 @@ fFlags = [
   ( "warn-missing-local-sigs",          Opt_WarnMissingLocalSigs, nop ),
   ( "warn-name-shadowing",              Opt_WarnNameShadowing, nop ),
   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns, nop ),
   ( "warn-missing-local-sigs",          Opt_WarnMissingLocalSigs, nop ),
   ( "warn-name-shadowing",              Opt_WarnNameShadowing, nop ),
   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns, nop ),

-  ( "warn-simple-patterns",             Opt_WarnSimplePatterns, nop ),

   ( "warn-type-defaults",               Opt_WarnTypeDefaults, nop ),
   ( "warn-monomorphism-restriction",    Opt_WarnMonomorphism, nop ),
   ( "warn-unused-binds",                Opt_WarnUnusedBinds, nop ),
   ( "warn-type-defaults",               Opt_WarnTypeDefaults, nop ),
   ( "warn-monomorphism-restriction",    Opt_WarnMonomorphism, nop ),
   ( "warn-unused-binds",                Opt_WarnUnusedBinds, nop ),

@@ -1442,6 +1422,7 @@ fFlags = [
   ( "warn-deprecations",                Opt_WarnWarningsDeprecations, nop ),
   ( "warn-deprecated-flags",            Opt_WarnDeprecatedFlags, nop ),
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),
   ( "warn-deprecations",                Opt_WarnWarningsDeprecations, nop ),
   ( "warn-deprecated-flags",            Opt_WarnDeprecatedFlags, nop ),
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),

+  ( "warn-auto-orphans",                Opt_WarnAutoOrphans, nop ),

   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
   ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
   ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),

@@ -1490,6 +1471,7 @@ fFlags = [
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
   ( "shared-implib",                    Opt_SharedImplib, nop ),
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
   ( "shared-implib",                    Opt_SharedImplib, nop ),

+  ( "ghci-sandbox",                     Opt_GhciSandbox, nop ),

   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop )
   ]
   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop )
   ]

@@ -1568,8 +1550,7 @@ xFlags = [
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
   ( "RankNTypes",                       Opt_RankNTypes, nop ),
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
   ( "RankNTypes",                       Opt_RankNTypes, nop ),

-  ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, 
-        \_ -> deprecate "impredicative polymorphism will be simplified or removed in GHC 6.14" ),
+  ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop), 

   ( "TypeOperators",                    Opt_TypeOperators, nop ),
   ( "RecursiveDo",                      Opt_RecursiveDo,
     deprecatedForExtension "DoRec"),
   ( "TypeOperators",                    Opt_TypeOperators, nop ),
   ( "RecursiveDo",                      Opt_RecursiveDo,
     deprecatedForExtension "DoRec"),

@@ -1593,6 +1574,7 @@ xFlags = [
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, nop ),
   ( "NPlusKPatterns",                   Opt_NPlusKPatterns, nop ),
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, nop ),
   ( "NPlusKPatterns",                   Opt_NPlusKPatterns, nop ),
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),

+  ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),

   ( "MonoPatBinds",                     Opt_MonoPatBinds, nop ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, nop ),
   ( "MonoPatBinds",                     Opt_MonoPatBinds, nop ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, nop ),

@@ -1644,7 +1626,8 @@ defaultFlags
 
       Opt_GenManifest,
       Opt_EmbedManifest,
 
       Opt_GenManifest,
       Opt_EmbedManifest,

-      Opt_PrintBindContents
+      Opt_PrintBindContents,
+      Opt_GhciSandbox

     ]
 
     ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
     ]
 
     ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]

@@ -1661,9 +1644,10 @@ impliedFlags
     , (Opt_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 
     , (Opt_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 

+    , (Opt_RebindableSyntax,          Opt_ImplicitPrelude)
+

     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)

-    , (Opt_FunctionalDependencies, Opt_MonoLocalBinds)

 
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
                                                     -- all over the place
 
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
                                                     -- all over the place

@@ -1760,9 +1744,9 @@ minuswRemovesOpts
     = minusWallOpts ++
       [Opt_WarnImplicitPrelude,
        Opt_WarnIncompletePatternsRecUpd,
     = minusWallOpts ++
       [Opt_WarnImplicitPrelude,
        Opt_WarnIncompletePatternsRecUpd,

-       Opt_WarnSimplePatterns,

        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,
        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,

+       Opt_WarnAutoOrphans,

        Opt_WarnTabs
       ]
 
        Opt_WarnTabs
       ]
 

@@ -1778,7 +1762,6 @@ glasgowExtsFlags :: [ExtensionFlag]
 glasgowExtsFlags = [
              Opt_ForeignFunctionInterface
            , Opt_UnliftedFFITypes
 glasgowExtsFlags = [
              Opt_ForeignFunctionInterface
            , Opt_UnliftedFFITypes

-           , Opt_GADTs

            , Opt_ImplicitParams
            , Opt_ScopedTypeVariables
            , Opt_UnboxedTuples
            , Opt_ImplicitParams
            , Opt_ScopedTypeVariables
            , Opt_UnboxedTuples

@@ -1806,8 +1789,7 @@ glasgowExtsFlags = [
            , Opt_ParallelListComp
            , Opt_EmptyDataDecls
            , Opt_KindSignatures
            , Opt_ParallelListComp
            , Opt_EmptyDataDecls
            , Opt_KindSignatures

-           , Opt_GeneralizedNewtypeDeriving
-           , Opt_TypeFamilies ]
+           , Opt_GeneralizedNewtypeDeriving ]

 
 #ifdef GHCI
 -- Consult the RTS to find whether GHC itself has been built profiled
 
 #ifdef GHCI
 -- Consult the RTS to find whether GHC itself has been built profiled

@@ -1868,10 +1850,6 @@ setDynFlag   f = upd (\dfs -> dopt_set dfs f)
 unSetDynFlag f = upd (\dfs -> dopt_unset 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 -> xopt_set dfs f)
                         ; mapM_ setExtensionFlag deps }
 setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
 setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f)
                         ; mapM_ setExtensionFlag deps }

@@ -2288,6 +2266,7 @@ compilerInfo = [("Project name",                String cProjectName),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),
                 ("Have llvm code generator",    String cGhcWithLlvmCodeGen),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),
                 ("Have llvm code generator",    String cGhcWithLlvmCodeGen),

+                ("Use archives for ghci",       String (show cUseArchivesForGhci)),

                 ("Support SMP",                 String cGhcWithSMP),
                 ("Unregisterised",              String cGhcUnregisterised),
                 ("Tables next to code",         String cGhcEnableTablesNextToCode),
                 ("Support SMP",                 String cGhcWithSMP),
                 ("Unregisterised",              String cGhcUnregisterised),
                 ("Tables next to code",         String cGhcEnableTablesNextToCode),