#include "ghclib_api.h"
{-# OPTIONS_GHC -Wno-orphans #-}
module Language.Haskell.GhclibParserEx.GHC.Driver.Session(
readExtension
, extensionImplications
#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
#if defined (GHC_8_8) || defined (GHC_8_10)
import Data.Function
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
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
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]
#if defined(GHC_8_8) || defined(GHC_8_10)
type TurnOnFlag = Bool
turnOn :: TurnOnFlag; turnOn = True
turnOff :: TurnOnFlag; turnOff = False
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)]
impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]
impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
impliedXFlags
= [ (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)
, (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies)
, (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)
, (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)
, (LangExt.PolyKinds, turnOn, LangExt.KindSignatures)
, (LangExt.TypeInType, turnOn, LangExt.DataKinds)
, (LangExt.TypeInType, turnOn, LangExt.PolyKinds)
, (LangExt.TypeInType, turnOn, LangExt.KindSignatures)
#if defined(GHC_8_10)
, (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
#endif
, (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)
, (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces)
, (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)
, (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes)
, (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)
, (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 (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 flags (stringToStringBuffer str) file
#endif
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
(DynFlags
flags, [Located String]
_, Messages DriverMessage
_) <- 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
Either String DynFlags -> IO (Either String DynFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DynFlags -> IO (Either String DynFlags))
-> Either String DynFlags -> IO (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Either String DynFlags
forall a b. b -> Either a b
Right (DynFlags
flags DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
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)