    -- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved.
    -- SPDX-License-Identifier: BSD-3-Clause.

    {- ORMOLU_DISABLE -}
    #include "ghclib_api.h"
    {-# OPTIONS_GHC -Wno-orphans #-}
    module Language.Haskell.GhclibParserEx.GHC.Driver.Session(
          readExtension
        , extensionImplications
    -- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2654.
    #if defined (GHC_8_8) || defined (GHC_8_10)
        , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags
    #endif
        , parsePragmasIntoDynFlags
      ) where

    #if defined (GHC_8_8)
    import qualified GHC.LanguageExtensions as LangExt
    import Panic
    import HeaderInfo
    import StringBuffer
    import DynFlags
    import HscTypes
    #elif defined (GHC_8_10)
    import qualified GHC.LanguageExtensions as LangExt
    import Panic
    import HeaderInfo
    import StringBuffer
    import DynFlags
    import HscTypes
    #elif defined (GHC_9_0)
    import GHC.Utils.Panic
    import GHC.Parser.Header
    import GHC.Data.StringBuffer
    import GHC.Driver.Session
    import GHC.Driver.Types
    #else
    import GHC.Utils.Panic
    import GHC.Parser.Header
    import GHC.Data.StringBuffer
    import GHC.Driver.Session
    import GHC.Types.SourceError
    #endif
    import GHC.LanguageExtensions.Type
    import Data.List
    import Data.Maybe
    import qualified Data.Map as Map

    -- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707.
    #if defined (GHC_8_8) || defined (GHC_8_10)
    import Data.Function -- For `compareOn`.
    instance Ord Extension where
      compare = compare `on` fromEnum
    #endif
    #if ! (defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined(GHC_8_8) )
    import GHC.Driver.Config.Parser
    #endif

    -- | Parse a GHC extension.
    readExtension :: String -> Maybe Extension
    readExtension :: String -> Maybe Extension
    readExtension String
    s = FlagSpec Extension -> Extension
    forall flag. FlagSpec flag -> flag
    flagSpecFlag (FlagSpec Extension -> Extension)
    -> Maybe (FlagSpec Extension) -> Maybe Extension
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (FlagSpec Extension -> Bool)
    -> [FlagSpec Extension] -> Maybe (FlagSpec Extension)
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\(FlagSpec String
    n Extension
    _ Bool -> DynP ()
    _ GhcFlagMode
    _) -> String
    n String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    s) [FlagSpec Extension]
    xFlags

    #if (defined (GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined(GHC_8_8) )
    -- | Implicitly enabled/disabled extensions.
    extensionImplications :: [(Extension, ([Extension], [Extension]))]
    extensionImplications :: [(Extension, ([Extension], [Extension]))]
    extensionImplications = ((String, ([Extension], [Extension]))
     -> (Extension, ([Extension], [Extension])))
    -> [(String, ([Extension], [Extension]))]
    -> [(Extension, ([Extension], [Extension]))]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, ([Extension], [Extension]))
    -> (Extension, ([Extension], [Extension]))
    forall {b}. (String, b) -> (Extension, b)
    f ([(String, ([Extension], [Extension]))]
     -> [(Extension, ([Extension], [Extension]))])
    -> [(String, ([Extension], [Extension]))]
    -> [(Extension, ([Extension], [Extension]))]
    forall a b. (a -> b) -> a -> b
    $ Map String ([Extension], [Extension])
    -> [(String, ([Extension], [Extension]))]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map String ([Extension], [Extension])
    implicationsMap
      where
        f :: (String, b) -> (Extension, b)
    f (String
    e, b
    ps) = (Maybe Extension -> Extension
    forall a. HasCallStack => Maybe a -> a
    fromJust (String -> Maybe Extension
    readExtension String
    e), b
    ps)
        implicationsMap :: Map.Map String ([Extension], [Extension])
        implicationsMap :: Map String ([Extension], [Extension])
    implicationsMap = (([Extension], [Extension])
     -> ([Extension], [Extension]) -> ([Extension], [Extension]))
    -> [(String, ([Extension], [Extension]))]
    -> Map String ([Extension], [Extension])
    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
    Map.fromListWith ([Extension], [Extension])
    -> ([Extension], [Extension]) -> ([Extension], [Extension])
    forall a. Semigroup a => a -> a -> a
    (<>)
          [(Extension -> String
    forall a. Show a => a -> String
    show Extension
    a, ([Extension
    c | Bool
    b], [Extension
    c | Bool -> Bool
    not Bool
    b]))
            | (Extension
    a, Bool
    flag, Extension
    c) <- [(Extension, Bool, Extension)]
    impliedXFlags,
              let b :: Bool
    b = Bool
    flag Bool -> Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bool
    turnOn
          ]
    #else
      {- defined (GHC_9_14) -}
    -- | Implicitly enabled/disabled extensions.
    extensionImplications :: [(Extension, ([Extension], [Extension]))]
    extensionImplications = map f $ Map.toList implicationsMap
      where
        f (e, ps) = (fromJust (readExtension e), ps)
        implicationsMap :: Map.Map String ([Extension], [Extension])
        implicationsMap = Map.fromListWith (<>)
          [(show a, ([strip c | b], [strip c | not b]))
            | (a, c) <- impliedXFlags,
              let b = case c of On _ -> True; Off _ -> False
          ]

        strip :: OnOff a -> a
        strip (On e) = e
        strip (Off e) = e
    #endif

    -- Landed in
    -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. Copied from
    -- 'ghc/compiler/main/DynFlags.hs'.
    #if defined(GHC_8_8) || defined(GHC_8_10)

    type TurnOnFlag = Bool   -- True  <=> we are turning the flag on
                             -- False <=> we are turning the flag off
    turnOn  :: TurnOnFlag; turnOn  = True
    turnOff :: TurnOnFlag; turnOff = False

    -- General flags that are switched on/off when other general flags are switched
    -- on
    impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
    impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)
                    ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)
                    ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)
                    ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
                    ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)
                    ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)
                    ,(Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
                    ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits)]

    -- General flags that are switched on/off when other general flags are switched
    -- off
    impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
    impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]

    impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
    impliedXFlags
    -- See Note [Updating flag description in the User's Guide]
      = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)
        , (LangExt.QuantifiedConstraints,     turnOn, LangExt.ExplicitForAll)
        , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)
        , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)
        , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
        , (LangExt.FlexibleInstances,         turnOn, LangExt.TypeSynonymInstances)
        , (LangExt.FunctionalDependencies,    turnOn, LangExt.MultiParamTypeClasses)
        , (LangExt.MultiParamTypeClasses,     turnOn, LangExt.ConstrainedClassMethods)  -- c.f. #7854
        , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)

        , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!

        , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)

        , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)
        , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)
        , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)

        , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures
        , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds

        -- TypeInType is now just a synonym for a couple of other extensions.
        , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)
        , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)
        , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)

    #if defined(GHC_8_10)
        -- Standalone kind signatures are a replacement for CUSKs.
        , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
    #endif

        -- AutoDeriveTypeable is not very useful without DeriveDataTypeable
        , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)

        -- We turn this on so that we can export associated type
        -- type synonyms in subordinates (e.g. MyClass(type AssocType))
        , (LangExt.TypeFamilies,     turnOn, LangExt.ExplicitNamespaces)
        , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)

        , (LangExt.ImpredicativeTypes,  turnOn, LangExt.RankNTypes)

            -- Record wild-cards implies field disambiguation
            -- Otherwise if you write (C {..}) you may well get
            -- stuff like " 'a' not in scope ", which is a bit silly
            -- if the compiler has just filled in field 'a' of constructor 'C'
        , (LangExt.RecordWildCards,     turnOn, LangExt.DisambiguateRecordFields)

        , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)

        , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)

        , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)
        , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)

        -- Duplicate record fields require field disambiguation
        , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)

        , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)
        , (LangExt.Strict, turnOn, LangExt.StrictData)
      ]
    #endif

    parsePragmasIntoDynFlags :: DynFlags
                             -> ([Extension], [Extension])
                             -> FilePath
                             -> String
                             -> IO (Either String DynFlags)
    parsePragmasIntoDynFlags :: DynFlags
    -> ([Extension], [Extension])
    -> String
    -> String
    -> IO (Either String DynFlags)
    parsePragmasIntoDynFlags DynFlags
    flags ([Extension]
    enable, [Extension]
    disable) String
    file String
    str =
      IO (Either String DynFlags) -> IO (Either String DynFlags)
    catchErrors (IO (Either String DynFlags) -> IO (Either String DynFlags))
    -> IO (Either String DynFlags) -> IO (Either String DynFlags)
    forall a b. (a -> b) -> a -> b
    $ do
    #if (defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8))
        let opts = getOptions flags (stringToStringBuffer str) file
    #elif (defined (GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4))
        let (Messages PsMessage
    _, [Located String]
    opts) = ParserOpts
    -> StringBuffer -> String -> (Messages PsMessage, [Located String])
    getOptions (DynFlags -> ParserOpts
    initParserOpts DynFlags
    flags) (String -> StringBuffer
    stringToStringBuffer String
    str) String
    file
    #else
        let (_, opts) = getOptions (initParserOpts flags) (supportedLanguagePragmas flags) (stringToStringBuffer str) file
    #endif
        -- Important : apply enables, disables *before* parsing dynamic
        -- file pragmas.
        let flags' :: DynFlags
    flags' =  (DynFlags -> Extension -> DynFlags)
    -> DynFlags -> [Extension] -> DynFlags
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' DynFlags -> Extension -> DynFlags
    xopt_set DynFlags
    flags [Extension]
    enable
        let flags'' :: DynFlags
    flags'' = (DynFlags -> Extension -> DynFlags)
    -> DynFlags -> [Extension] -> DynFlags
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' DynFlags -> Extension -> DynFlags
    xopt_unset DynFlags
    flags' [Extension]
    disable
        (flags, _, _) <- DynFlags
    -> [Located String]
    -> IO (DynFlags, [Located String], Messages DriverMessage)
    forall (m :: * -> *).
    MonadIO m =>
    DynFlags
    -> [Located String]
    -> m (DynFlags, [Located String], Messages DriverMessage)
    parseDynamicFilePragma DynFlags
    flags'' [Located String]
    opts
        return $ Right (flags `gopt_set` Opt_KeepRawTokenStream)
      where
        catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
        catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
    catchErrors IO (Either String DynFlags)
    act = (GhcException -> IO (Either String DynFlags))
    -> IO (Either String DynFlags) -> IO (Either String DynFlags)
    forall (m :: * -> *) a.
    ExceptionMonad m =>
    (GhcException -> m a) -> m a -> m a
    handleGhcException GhcException -> IO (Either String DynFlags)
    forall {m :: * -> *} {a} {b}.
    (Monad m, Show a) =>
    a -> m (Either String b)
    reportErr
                            ((SourceError -> IO (Either String DynFlags))
    -> IO (Either String DynFlags) -> IO (Either String DynFlags)
    forall (m :: * -> *) a.
    MonadCatch m =>
    (SourceError -> m a) -> m a -> m a
    handleSourceError SourceError -> IO (Either String DynFlags)
    forall {m :: * -> *} {a} {b}.
    (Monad m, Show a) =>
    a -> m (Either String b)
    reportErr IO (Either String DynFlags)
    act)
        reportErr :: a -> m (Either String b)
    reportErr a
    e = Either String b -> m (Either String b)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either String b -> m (Either String b))
    -> Either String b -> m (Either String b)
    forall a b. (a -> b) -> a -> b
    $ String -> Either String b
    forall a b. a -> Either a b
    Left (a -> String
    forall a. Show a => a -> String
    show a
    e)