Remove the need to explicitly flatten the dynflags

4 files changed, 45 insertions, 81 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index c690e84ed0..1c29c7f688 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -694,30 +694,27 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 
 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
-       let dflags0' = flattenExtensionFlags dflags0
-       src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
+       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
        (dflags1, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
        checkProcessArgsResult unhandled_flags
-       let dflags1' = flattenExtensionFlags dflags1
 
-       if not (xopt Opt_Cpp dflags1') then do
+       if not (xopt Opt_Cpp dflags1) then do
            -- we have to be careful to emit warnings only once.
-           unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
+           unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
 
            -- no need to preprocess CPP, just pass input file along
            -- to the next phase of the pipeline.
            return (HsPp sf, dflags1, maybe_loc, input_fn)
         else do
-            output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
-            liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
+            output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
+            liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
             -- re-read the pragmas now that we've preprocessed the file
             -- See #2464,#3457
-            src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
             (dflags2, unhandled_flags, warns)
                 <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
-            let dflags2' = flattenExtensionFlags dflags2
-            unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
+            unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
             -- the HsPp pass below will emit warnings
             checkProcessArgsResult unhandled_flags
 
@@ -728,11 +725,10 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 
 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
   = do let dflags = hsc_dflags hsc_env
-           dflags' = flattenExtensionFlags dflags
        if not (dopt Opt_Pp dflags) then
            -- no need to preprocess, just pass input file along
            -- to the next phase of the pipeline.
-          return (Hsc sf, dflags', maybe_loc, input_fn)
+          return (Hsc sf, dflags, maybe_loc, input_fn)
         else do
             let hspp_opts = getOpts dflags opt_F
             let orig_fn = basename <.> suff
@@ -746,14 +742,13 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
                            )
 
             -- re-read pragmas now that we've parsed the file (see #3674)
-            src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
+            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
             (dflags1, unhandled_flags, warns)
                 <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
-            let dflags1' = flattenExtensionFlags dflags1
-            handleFlagWarnings dflags1' warns
+            handleFlagWarnings dflags1 warns
             checkProcessArgsResult unhandled_flags
 
-            return (Hsc sf, dflags1', maybe_loc, output_fn)
+            return (Hsc sf, dflags1, maybe_loc, output_fn)
 
 -----------------------------------------------------------------------------
 -- Hsc phase
@@ -901,14 +896,13 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
        let dflags = hsc_dflags hsc_env
-           dflags' = flattenExtensionFlags dflags
-       output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
-       liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
-       return (Cmm, dflags', maybe_loc, output_fn)
+       output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
+       liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
+       return (Cmm, dflags, maybe_loc, output_fn)
 
 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
   = do
-        let dflags = ensureFlattenedExtensionFlags $ hsc_dflags hsc_env
+        let dflags = hsc_dflags hsc_env
         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 96037f4af4..fa92d572a9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -17,16 +17,12 @@ module DynFlags (
         DynFlag(..),
         ExtensionFlag(..),
         glasgowExtsFlags,
-        flattenExtensionFlags,
-        ensureFlattenedExtensionFlags,
         dopt,
         dopt_set,
         dopt_unset,
         xopt,
         xopt_set,
         xopt_unset,
-        xopt_set_flattened,
-        xopt_unset_flattened,
         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,
@@ -501,9 +497,13 @@ data DynFlags = DynFlags {
 
   -- hsc dynamic flags
   flags                 :: [DynFlag],
+  -- Don't change this without updating extensionFlags:
   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 (),
@@ -741,7 +741,8 @@ defaultDynFlags =
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,
-        extensionFlags = Left [],
+        extensions = [],
+        extensionFlags = flattenExtensionFlags Nothing [],
 
         log_action = \severity srcSpan style msg ->
                         case severity of
@@ -770,31 +771,11 @@ Note [Verbosity levels]
 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
-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
@@ -837,37 +818,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
 
 -- | 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
-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
-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
@@ -1872,10 +1846,6 @@ 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 -> xopt_set dfs f)
                         ; mapM_ setExtensionFlag deps }
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 646abca0c2..097db0449b 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -253,7 +253,7 @@ doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 
 setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-			 env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
+			 env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
 
 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 11a3c98f10..7249ef4c46 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1194,7 +1194,7 @@ shellEscape str = io (system str >> return False)
 withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
 withFlattenedDynflags m
     = do dflags <- GHC.getSessionDynFlags
-         gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags))
+         gbracket (GHC.setSessionDynFlags dflags)
                   (\_ -> GHC.setSessionDynFlags dflags)
                   (\_ -> m)