{-# LANGUAGE NoImplicitPrelude, CPP #-}
module IHaskell.Eval.Util (
initGhci,
extensionFlag,
setExtension,
ExtFlag(..),
setFlags,
setWayDynFlag,
evalImport,
removeImport,
evalDeclarations,
getType,
getDescription,
doc,
pprDynFlags,
pprLanguages,
unfoldM,
) where
import IHaskellPrelude
#if MIN_VERSION_ghc(8,6,0)
#else
import qualified Data.ByteString.Char8 as CBS
#endif
#if MIN_VERSION_ghc(9,8,0)
import GHC.Core.InstEnv (is_cls, is_tys, mkInstEnv, instEnvElts)
import GHC.Core.Unify
import GHC.Data.Bag
import GHC.Types.TyThing.Ppr
import GHC.Driver.CmdLine
import GHC.Driver.Monad (modifySession)
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Env.Types
import GHC.Platform.Ways
import GHC.Runtime.Context
import GHC.Types.Error
import GHC.Types.Name (pprInfixName)
import GHC.Types.Name.Set
import GHC.Types.TyThing
import qualified GHC.Driver.Session as DynFlags
import qualified GHC.Utils.Error as E
import qualified GHC.Utils.Outputable as O
import qualified GHC.Utils.Ppr as Pretty
import GHC.Runtime.Loader
#elif MIN_VERSION_ghc(9,4,0)
import GHC.Core.InstEnv (is_cls, is_tys, mkInstEnv, instEnvElts)
import GHC.Core.Unify
import GHC.Types.TyThing.Ppr
import GHC.Driver.CmdLine
import GHC.Driver.Monad (modifySession)
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Env.Types
import GHC.Platform.Ways
import GHC.Runtime.Context
import GHC.Types.Name (pprInfixName)
import GHC.Types.Name.Set
import GHC.Types.TyThing
import qualified GHC.Driver.Session as DynFlags
import qualified GHC.Utils.Outputable as O
import qualified GHC.Utils.Ppr as Pretty
import GHC.Runtime.Loader
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Core.InstEnv (is_cls, is_tys)
import GHC.Core.Unify
import GHC.Types.TyThing.Ppr
import GHC.Driver.CmdLine
import GHC.Driver.Monad (modifySession)
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Env.Types
import GHC.Platform.Ways
import GHC.Runtime.Context
import GHC.Types.Name (pprInfixName)
import GHC.Types.Name.Set
import GHC.Types.TyThing
import qualified GHC.Driver.Session as DynFlags
import qualified GHC.Utils.Outputable as O
import qualified GHC.Utils.Ppr as Pretty
import GHC.Runtime.Loader
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Core.InstEnv (is_cls, is_tys)
import GHC.Core.Unify
import GHC.Core.Ppr.TyThing
import GHC.Driver.CmdLine
import GHC.Driver.Monad (modifySession)
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.Driver.Ways
import GHC.Types.Name (pprInfixName)
import GHC.Types.Name.Set
import qualified GHC.Driver.Session as DynFlags
import qualified GHC.Utils.Outputable as O
import qualified GHC.Utils.Ppr as Pretty
import GHC.Runtime.Loader
#else
import DynFlags
import GhcMonad
import HscTypes
import NameSet
import Name
import PprTyThing
import InstEnv (ClsInst(..))
import Unify (tcMatchTys)
import qualified Pretty
import qualified Outputable as O
#if MIN_VERSION_ghc(8,6,0)
import DynamicLoading
#endif
#endif
#if MIN_VERSION_ghc(8,6,0)
#else
import FastString
#endif
import GHC
import StringUtils (replace)
#if MIN_VERSION_ghc(9,0,0)
#elif MIN_VERSION_ghc(8,4,0)
import CmdLineParser (warnMsg)
#endif
import GHC.LanguageExtensions
type ExtensionFlag = Extension
data ExtFlag = SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
extensionFlag :: String
-> Maybe ExtFlag
extensionFlag :: String -> Maybe ExtFlag
extensionFlag String
ext =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall {flag}. String -> FlagSpec flag -> Bool
flagMatches String
ext) [FlagSpec Extension]
xFlags of
Just FlagSpec Extension
fs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Extension -> ExtFlag
SetFlag forall a b. (a -> b) -> a -> b
$ forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
fs
Maybe (FlagSpec Extension)
Nothing ->
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall {flag}. String -> FlagSpec flag -> Bool
flagMatchesNo String
ext) [FlagSpec Extension]
xFlags of
Just FlagSpec Extension
fs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Extension -> ExtFlag
UnsetFlag forall a b. (a -> b) -> a -> b
$ forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
fs
Maybe (FlagSpec Extension)
Nothing -> forall a. Maybe a
Nothing
where
flagMatches :: String -> FlagSpec flag -> Bool
flagMatches String
ex FlagSpec flag
fs = String
ex forall a. Eq a => a -> a -> Bool
== forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
fs
flagMatchesNo :: String -> FlagSpec flag -> Bool
flagMatchesNo String
ex FlagSpec flag
fs = String
ex forall a. Eq a => a -> a -> Bool
== String
"No" forall a. [a] -> [a] -> [a]
++ forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
fs
#if MIN_VERSION_ghc(9,2,0)
addWay' :: Way
-> DynFlags
-> DynFlags
addWay' :: Way -> DynFlags -> DynFlags
addWay' Way
w DynFlags
dflags0 =
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags0
dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { targetWays_ :: Ways
targetWays_ = Way -> Ways -> Ways
addWay Way
w (DynFlags -> Ways
targetWays_ DynFlags
dflags0) }
dflags2 :: DynFlags
dflags2 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' DynFlags
dflags1 (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform Way
w)
dflags3 :: DynFlags
dflags3 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GeneralFlag -> DynFlags -> DynFlags
unSetGeneralFlag' DynFlags
dflags2 (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform Way
w)
in DynFlags
dflags3
#endif
setWayDynFlag :: DynFlags
-> DynFlags
setWayDynFlag :: DynFlags -> DynFlags
setWayDynFlag =
if Bool
hostIsDynamic
then Way -> DynFlags -> DynFlags
addWay' Way
WayDyn
else forall a. a -> a
id
#if MIN_VERSION_ghc(9,0,0)
#else
where
hostIsDynamic = dynamicGhc
#endif
pprDynFlags :: Bool
-> DynFlags
-> O.SDoc
pprDynFlags :: Bool -> DynFlags -> SDoc
pprDynFlags Bool
show_all DynFlags
dflags =
[SDoc] -> SDoc
O.vcat
[ String -> SDoc
O.text String
"GHCi-specific dynamic flag settings:" SDoc -> SDoc -> SDoc
O.$$
Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting GeneralFlag -> DynFlags -> Bool
opt) [FlagSpec GeneralFlag]
ghciFlags))
, String -> SDoc
O.text String
"other dynamic, non-language, flag settings:" SDoc -> SDoc -> SDoc
O.$$
Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting GeneralFlag -> DynFlags -> Bool
opt) [FlagSpec GeneralFlag]
others))
, String -> SDoc
O.text String
"warning settings:" SDoc -> SDoc -> SDoc
O.$$
Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting WarningFlag -> DynFlags -> Bool
wopt) [FlagSpec WarningFlag]
wFlags))
]
where
wFlags :: [FlagSpec WarningFlag]
wFlags = [FlagSpec WarningFlag]
DynFlags.wWarningFlags
opt :: GeneralFlag -> DynFlags -> Bool
opt = GeneralFlag -> DynFlags -> Bool
gopt
setting :: (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting flag -> DynFlags -> Bool
test FlagSpec flag
flag
| Bool
quiet = SDoc
O.empty :: O.SDoc
| Bool
is_on = String -> SDoc
fstr String
name :: O.SDoc
| Bool
otherwise = String -> SDoc
fnostr String
name :: O.SDoc
where
name :: String
name = forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
f :: flag
f = forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec flag
flag
is_on :: Bool
is_on = flag -> DynFlags -> Bool
test flag
f DynFlags
dflags
quiet :: Bool
quiet = Bool -> Bool
not Bool
show_all Bool -> Bool -> Bool
&& flag -> DynFlags -> Bool
test flag
f DynFlags
default_dflags forall a. Eq a => a -> a -> Bool
== Bool
is_on
#if MIN_VERSION_ghc(9,6,0)
default_dflags = defaultDynFlags (settings dflags)
#elif MIN_VERSION_ghc(8,10,0)
default_dflags :: DynFlags
default_dflags = Settings -> LlvmConfig -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags)
#elif MIN_VERSION_ghc(8,6,0)
default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags)
#elif MIN_VERSION_ghc(8,4,0)
default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags)
#else
default_dflags = defaultDynFlags (settings dflags)
#endif
fstr, fnostr :: String -> O.SDoc
fstr :: String -> SDoc
fstr String
str = String -> SDoc
O.text String
"-f" SDoc -> SDoc -> SDoc
O.<> String -> SDoc
O.text String
str
fnostr :: String -> SDoc
fnostr String
str = String -> SDoc
O.text String
"-fno-" SDoc -> SDoc -> SDoc
O.<> String -> SDoc
O.text String
str
([FlagSpec GeneralFlag]
ghciFlags, [FlagSpec GeneralFlag]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\FlagSpec GeneralFlag
f -> forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec GeneralFlag
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GeneralFlag]
flgs) [FlagSpec GeneralFlag]
DynFlags.fFlags
flgs :: [GeneralFlag]
flgs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GeneralFlag]
flgs1, [GeneralFlag]
flgs2, [GeneralFlag]
flgs3]
flgs1 :: [GeneralFlag]
flgs1 = [GeneralFlag
Opt_PrintExplicitForalls]
flgs2 :: [GeneralFlag]
flgs2 = [GeneralFlag
Opt_PrintExplicitKinds]
flgs3 :: [GeneralFlag]
flgs3 :: [GeneralFlag]
flgs3 = [GeneralFlag
Opt_PrintBindResult, GeneralFlag
Opt_BreakOnException, GeneralFlag
Opt_BreakOnError, GeneralFlag
Opt_PrintEvldWithShow]
pprLanguages :: Bool
-> DynFlags
-> O.SDoc
pprLanguages :: Bool -> DynFlags -> SDoc
pprLanguages Bool
show_all DynFlags
dflags =
[SDoc] -> SDoc
O.vcat
[ String -> SDoc
O.text String
"base language is: " SDoc -> SDoc -> SDoc
O.<>
case DynFlags -> Maybe Language
language DynFlags
dflags of
Maybe Language
Nothing -> String -> SDoc
O.text String
"Haskell2010"
Just Language
Haskell98 -> String -> SDoc
O.text String
"Haskell98"
Just Language
Haskell2010 -> String -> SDoc
O.text String
"Haskell2010"
#if MIN_VERSION_ghc(9,4,0)
Just GHC2021 -> O.text "GHC2021"
#else
#endif
, (if Bool
show_all
then String -> SDoc
O.text String
"all active language options:"
else String -> SDoc
O.text String
"with the following modifiers:") SDoc -> SDoc -> SDoc
O.$$
Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting Extension -> DynFlags -> Bool
xopt) [FlagSpec Extension]
DynFlags.xFlags))
]
where
setting :: (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting flag -> DynFlags -> Bool
test FlagSpec flag
flag
| Bool
quiet = SDoc
O.empty
| Bool
is_on = String -> SDoc
O.text String
"-X" SDoc -> SDoc -> SDoc
O.<> String -> SDoc
O.text String
name
| Bool
otherwise = String -> SDoc
O.text String
"-XNo" SDoc -> SDoc -> SDoc
O.<> String -> SDoc
O.text String
name
where
name :: String
name = forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
f :: flag
f = forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec flag
flag
is_on :: Bool
is_on = flag -> DynFlags -> Bool
test flag
f DynFlags
dflags
quiet :: Bool
quiet = Bool -> Bool
not Bool
show_all Bool -> Bool -> Bool
&& flag -> DynFlags -> Bool
test flag
f DynFlags
default_dflags forall a. Eq a => a -> a -> Bool
== Bool
is_on
default_dflags :: DynFlags
default_dflags =
#if MIN_VERSION_ghc(9,6,0)
defaultDynFlags (settings dflags) `lang_set`
#elif MIN_VERSION_ghc(8,10,0)
Settings -> LlvmConfig -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags) DynFlags -> Maybe Language -> DynFlags
`lang_set`
#elif MIN_VERSION_ghc(8,6,0)
defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags) `lang_set`
#elif MIN_VERSION_ghc(8,4,0)
defaultDynFlags (settings dflags) (llvmTargets dflags) `lang_set`
#else
defaultDynFlags (settings dflags) `lang_set`
#endif
case DynFlags -> Maybe Language
language DynFlags
dflags of
Maybe Language
Nothing -> forall a. a -> Maybe a
Just Language
Haskell2010
Maybe Language
other -> Maybe Language
other
setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension :: forall (m :: * -> *). GhcMonad m => String -> m (Maybe String)
setExtension String
ext = do
DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
case String -> Maybe ExtFlag
extensionFlag String
ext of
Maybe ExtFlag
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"Could not parse extension name: " forall a. [a] -> [a] -> [a]
++ String
ext
Just ExtFlag
flag -> do
()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags forall a b. (a -> b) -> a -> b
$
case ExtFlag
flag of
SetFlag Extension
ghcFlag -> DynFlags -> Extension -> DynFlags
xopt_set DynFlags
flags Extension
ghcFlag
UnsetFlag Extension
ghcFlag -> DynFlags -> Extension -> DynFlags
xopt_unset DynFlags
flags Extension
ghcFlag
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
setFlags :: GhcMonad m => [String] -> m [String]
setFlags :: forall (m :: * -> *). GhcMonad m => [String] -> m [String]
setFlags [String]
ext = do
DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
(DynFlags
flags0, [Located String]
unrecognized, [Warn]
warnings) <- forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags Logger
logger DynFlags
flags (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
noLoc [String]
ext)
#else
(flags0, unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
#endif
let flags1 :: DynFlags
flags1 = DynFlags
flags0 { packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
flags }
#if MIN_VERSION_ghc(9,2,0)
let flags2 :: DynFlags
flags2 = DynFlags
flags1
#elif MIN_VERSION_ghc(8,6,0)
hsc_env <- GHC.getSession
flags2 <- liftIO (initializePlugins hsc_env flags1)
#else
let flags2 = flags1
#endif
Bool
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags DynFlags
flags2
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
flags2
let noParseErrs :: [String]
noParseErrs = forall a b. (a -> b) -> [a] -> [b]
map ((String
"Could not parse: " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [Located String]
unrecognized
#if MIN_VERSION_ghc(9,8,0)
allWarns = map (show . flip O.runSDoc O.defaultSDocContext . E.formatBulleted . diagnosticMessage defaultOpts . errMsgDiagnostic) (bagToList $ getWarningMessages warnings) ++
#elif MIN_VERSION_ghc(8,4,0)
allWarns :: [String]
allWarns = forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warn -> Located String
warnMsg) [Warn]
warnings forall a. [a] -> [a] -> [a]
++
#else
allWarns = map unLoc warnings ++
#endif
[String
"-package not supported yet" | forall a. Eq a => [a] -> [a]
nub (DynFlags -> [PackageFlag]
packageFlags DynFlags
flags) forall a. Eq a => a -> a -> Bool
/= forall a. Eq a => [a] -> [a]
nub (DynFlags -> [PackageFlag]
packageFlags DynFlags
flags0)]
warnErrs :: [String]
warnErrs = forall a b. (a -> b) -> [a] -> [b]
map (String
"Warning: " forall a. [a] -> [a] -> [a]
++) [String]
allWarns
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String]
noParseErrs forall a. [a] -> [a] -> [a]
++ [String]
warnErrs
doc :: GhcMonad m => O.SDoc -> m String
doc :: forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc SDoc
sdoc = do
DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,6,0)
let unqual = O.neverQualify
#else
PrintUnqualified
unqual <- forall (m :: * -> *). GhcMonad m => m PrintUnqualified
getPrintUnqual
#endif
#if MIN_VERSION_ghc(9,0,0)
let style :: PprStyle
style = PrintUnqualified -> Depth -> PprStyle
O.mkUserStyle PrintUnqualified
unqual Depth
O.AllTheWay
#elif MIN_VERSION_ghc(8,2,0)
let style = O.mkUserStyle flags unqual O.AllTheWay
#else
let style = O.mkUserStyle unqual O.AllTheWay
#endif
let cols :: Int
cols = DynFlags -> Int
pprCols DynFlags
flags
#if MIN_VERSION_ghc(9,2,0)
d :: Doc
d = SDoc -> SDocContext -> Doc
O.runSDoc SDoc
sdoc (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
flags PprStyle
style)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
Pretty.fullRender (Bool -> Mode
Pretty.PageMode Bool
False) Int
cols Float
1.5 TextDetails -> String -> String
string_txt String
"" Doc
d
#else
d = O.runSDoc sdoc (O.initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
#endif
where
string_txt :: Pretty.TextDetails -> String -> String
#if MIN_VERSION_ghc(8,6,0)
string_txt :: TextDetails -> String -> String
string_txt = TextDetails -> String -> String
Pretty.txtPrinter
#else
string_txt (Pretty.Chr c) s = c : s
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
string_txt (Pretty.ZStr s1) s2 = CBS.unpack (fastZStringToByteString s1) ++ s2
#endif
initGhci :: GhcMonad m => Maybe String -> m ()
initGhci :: forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhci Maybe String
sandboxPackages = do
#if MIN_VERSION_ghc(9,2,0)
DynFlags
originalFlagsNoPackageEnv <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
originalFlags <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger DynFlags
originalFlagsNoPackageEnv
#elif MIN_VERSION_ghc(9,0,0)
originalFlagsNoPackageEnv <- getSessionDynFlags
originalFlags <- liftIO $ interpretPackageEnv originalFlagsNoPackageEnv
#else
originalFlags <- getSessionDynFlags
#endif
let flag :: Extension -> DynFlags -> DynFlags
flag = forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Extension -> DynFlags
xopt_set
unflag :: Extension -> DynFlags -> DynFlags
unflag = forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Extension -> DynFlags
xopt_unset
dflags :: DynFlags
dflags = Extension -> DynFlags -> DynFlags
flag Extension
ExtendedDefaultRules forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> DynFlags -> DynFlags
unflag Extension
MonomorphismRestriction forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setWayDynFlag DynFlags
originalFlags
#if MIN_VERSION_ghc(8,2,0)
pkgFlags :: [PackageDBFlag]
pkgFlags =
case Maybe String
sandboxPackages of
Maybe String
Nothing -> DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
originalFlags
Just String
path ->
#if MIN_VERSION_ghc(9,0,0)
let pkg :: PackageDBFlag
pkg = PkgDbRef -> PackageDBFlag
PackageDB forall a b. (a -> b) -> a -> b
$ String -> PkgDbRef
PkgDbPath String
path
#else
let pkg = PackageDB $ PkgConfFile path
#endif
in DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
originalFlags forall a. [a] -> [a] -> [a]
++ [PackageDBFlag
pkg]
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags forall a b. (a -> b) -> a -> b
$ DynFlags
dflags
#if MIN_VERSION_ghc(9,6,0)
{ backend = interpreterBackend
#elif MIN_VERSION_ghc(9,2,0)
{ backend :: Backend
backend = Backend
Interpreter
#else
{ hscTarget = HscInterpreted
#endif
, ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory
, pprCols :: Int
pprCols = Int
300
, packageDBFlags :: [PackageDBFlag]
packageDBFlags = [PackageDBFlag]
pkgFlags
}
#else
pkgConfs =
case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
Just path ->
let pkg = PkgConfFile path
in (pkg :) . extraPkgConfs originalFlags
void $ setSessionDynFlags $ dflags
{ hscTarget = HscInterpreted
, ghcLink = LinkInMemory
, pprCols = 300
, extraPkgConfs = pkgConfs
}
#endif
evalImport :: GhcMonad m => String -> m ()
evalImport :: forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
imports = do
ImportDecl GhcPs
importDecl <- forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
imports
[InteractiveImport]
context <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
let noImplicit :: [InteractiveImport]
noImplicit = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> InteractiveImport -> Bool
implicitImportOf ImportDecl GhcPs
importDecl) [InteractiveImport]
context
oldImps :: [InteractiveImport]
oldImps = if ImportDecl GhcPs -> Bool
isHiddenImport ImportDecl GhcPs
importDecl
then forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> InteractiveImport -> Bool
importOf ImportDecl GhcPs
importDecl) [InteractiveImport]
context
else [InteractiveImport]
noImplicit
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
importDecl forall a. a -> [a] -> [a]
: [InteractiveImport]
oldImps
where
#if MIN_VERSION_ghc(8,4,0)
importOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
#else
importOf :: ImportDecl RdrName -> InteractiveImport -> Bool
#endif
importOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
importOf ImportDecl GhcPs
_ (IIModule ModuleName
_) = Bool
False
importOf ImportDecl GhcPs
imp (IIDecl ImportDecl GhcPs
decl) =
#if MIN_VERSION_ghc(8,10,0)
(forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName)) ImportDecl GhcPs
decl ImportDecl GhcPs
imp Bool -> Bool -> Bool
&& Bool -> Bool
not (ImportDeclQualifiedStyle -> Bool
isImportDeclQualified forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
decl)
#else
((==) `on` (unLoc . ideclName)) decl imp && not (ideclQualified decl)
#endif
#if MIN_VERSION_ghc(9,6,0)
implicitImportOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit (ideclExt decl) && imp `importOf` IIDecl decl
#elif MIN_VERSION_ghc(8,4,0)
implicitImportOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
implicitImportOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
implicitImportOf ImportDecl GhcPs
_ (IIModule ModuleName
_) = Bool
False
implicitImportOf ImportDecl GhcPs
imp (IIDecl ImportDecl GhcPs
decl) = forall pass. ImportDecl pass -> Bool
ideclImplicit ImportDecl GhcPs
decl Bool -> Bool -> Bool
&& ImportDecl GhcPs
imp ImportDecl GhcPs -> InteractiveImport -> Bool
`importOf` ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
decl
#else
implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl
#endif
#if MIN_VERSION_ghc(9,6,0)
isHiddenImport :: ImportDecl GhcPs -> Bool
isHiddenImport imp =
case ideclImportList imp of
Just (EverythingBut, _) -> True
_ -> False
#elif MIN_VERSION_ghc(8,4,0)
isHiddenImport :: ImportDecl GhcPs -> Bool
isHiddenImport :: ImportDecl GhcPs -> Bool
isHiddenImport ImportDecl GhcPs
imp =
case forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding ImportDecl GhcPs
imp of
Just (Bool
True, XRec GhcPs [LIE GhcPs]
_) -> Bool
True
Maybe (Bool, XRec GhcPs [LIE GhcPs])
_ -> Bool
False
#else
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp =
case ideclHiding imp of
Just (True, _) -> True
_ -> False
#endif
removeImport :: GhcMonad m => String -> m ()
removeImport :: forall (m :: * -> *). GhcMonad m => String -> m ()
removeImport String
modName = do
[InteractiveImport]
ctx <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
let ctx' :: [InteractiveImport]
ctx' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> InteractiveImport -> Bool
isImportOf forall a b. (a -> b) -> a -> b
$ String -> ModuleName
mkModuleName String
modName)) [InteractiveImport]
ctx
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
ctx'
where
isImportOf :: ModuleName -> InteractiveImport -> Bool
isImportOf :: ModuleName -> InteractiveImport -> Bool
isImportOf ModuleName
name (IIModule ModuleName
mName) = ModuleName
name forall a. Eq a => a -> a -> Bool
== ModuleName
mName
isImportOf ModuleName
name (IIDecl ImportDecl GhcPs
impDecl) = ModuleName
name forall a. Eq a => a -> a -> Bool
== forall l e. GenLocated l e -> e
unLoc (forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
impDecl)
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations :: forall (m :: * -> *). GhcMonad m => String -> m [String]
evalDeclarations String
decl = do
[Name]
names <- forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls String
decl
forall (m :: * -> *). GhcMonad m => m ()
cleanUpDuplicateInstances
DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String -> String
replace String
":Interactive." String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
flags) [Name]
names
#else
return $ map (replace ":Interactive." "" . O.showPpr flags) names
#endif
cleanUpDuplicateInstances :: GhcMonad m => m ()
cleanUpDuplicateInstances :: forall (m :: * -> *). GhcMonad m => m ()
cleanUpDuplicateInstances = forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hscEnv ->
let
ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hscEnv
([ClsInst]
clsInsts, [FamInst]
famInsts) = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
ic
#if MIN_VERSION_ghc(9,4,0)
clsInsts' = mkInstEnv $ nubBy instEq $ instEnvElts clsInsts
#else
clsInsts' :: [ClsInst]
clsInsts' = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ClsInst -> ClsInst -> Bool
instEq [ClsInst]
clsInsts
#endif
in HscEnv
hscEnv { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic { ic_instances :: ([ClsInst], [FamInst])
ic_instances = ([ClsInst]
clsInsts', [FamInst]
famInsts) } }
where
instEq :: ClsInst -> ClsInst -> Bool
instEq :: ClsInst -> ClsInst -> Bool
instEq ClsInst
c1 ClsInst
c2 =
ClsInst -> Class
is_cls ClsInst
c1 forall a. Eq a => a -> a -> Bool
== ClsInst -> Class
is_cls ClsInst
c2 Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys (ClsInst -> [Type]
is_tys ClsInst
c1) (ClsInst -> [Type]
is_tys ClsInst
c2))
getType :: GhcMonad m => String -> m String
getType :: forall (m :: * -> *). GhcMonad m => String -> m String
getType String
expr = do
#if MIN_VERSION_ghc(8,2,0)
Type
result <- forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
exprType TcRnExprMode
TM_Inst String
expr
#else
result <- exprType expr
#endif
DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
let typeStr :: String
typeStr = DynFlags -> SDoc -> String
showSDoc DynFlags
flags forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
O.ppr Type
result
#else
let typeStr = O.showSDocUnqual flags $ O.ppr result
#endif
forall (m :: * -> *) a. Monad m => a -> m a
return String
typeStr
unfoldM :: IO (Maybe a) -> IO [a]
unfoldM :: forall a. IO (Maybe a) -> IO [a]
unfoldM IO (Maybe a)
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) (\a
r -> (a
r forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (Maybe a) -> IO [a]
unfoldM IO (Maybe a)
f) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe a)
f
getDescription :: GhcMonad m => String -> m [String]
getDescription :: forall (m :: * -> *). GhcMonad m => String -> m [String]
getDescription String
str = do
[Name]
names <- forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
str
[Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
maybeInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo' [Name]
names
#if MIN_VERSION_ghc(9,6,0)
let infos = catMaybes $ nonEmptyToList maybeInfos
#else
let infos :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos = forall a. [Maybe a] -> [a]
catMaybes [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
maybeInfos
#endif
allNames :: NameSet
allNames = [Name] -> NameSet
mkNameSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. NamedThing a => a -> Name
getName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> a
getInfoType) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos
hasParent :: (TyThing, b, c, d, e) -> Bool
hasParent (TyThing, b, c, d, e)
info =
case TyThing -> Maybe TyThing
tyThingParent_maybe (forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> a
getInfoType (TyThing, b, c, d, e)
info) of
Just TyThing
parent -> forall a. NamedThing a => a -> Name
getName TyThing
parent Name -> NameSet -> Bool
`elemNameSet` NameSet
allNames
Maybe TyThing
Nothing -> Bool
False
filteredOutput :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filteredOutput = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b} {c} {d} {e}. (TyThing, b, c, d, e) -> Bool
hasParent) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e}. (TyThing, Fixity, [ClsInst], [FamInst], e) -> SDoc
printInfo) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filteredOutput
where
getInfo' :: Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo' = forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo Bool
False
#if MIN_VERSION_ghc(8,4,0)
getInfoType :: (a, b, c, d, e) -> a
getInfoType (a
theType, b
_, c
_, d
_, e
_) = a
theType
#else
getInfoType (theType, _, _, _) = theType
#endif
#if MIN_VERSION_ghc(8,4,0)
printInfo :: (TyThing, Fixity, [ClsInst], [FamInst], e) -> SDoc
printInfo (TyThing
thing, Fixity
fixity, [ClsInst]
classInstances, [FamInst]
famInstances, e
_) =
TyThing -> SDoc
pprTyThingInContextLoc TyThing
thing SDoc -> SDoc -> SDoc
O.$$
forall {a}. NamedThing a => a -> Fixity -> SDoc
showFixity TyThing
thing Fixity
fixity SDoc -> SDoc -> SDoc
O.$$
[SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
GHC.pprInstance [ClsInst]
classInstances) SDoc -> SDoc -> SDoc
O.$$
[SDoc] -> SDoc
O.vcat (forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
GHC.pprFamInst [FamInst]
famInstances)
#else
printInfo (thing, fixity, classInstances, famInstances) =
pprTyThingInContextLoc thing O.$$
showFixity thing fixity O.$$
O.vcat (map GHC.pprInstance classInstances) O.$$
O.vcat (map GHC.pprFamInst famInstances)
#endif
showFixity :: a -> Fixity -> SDoc
showFixity a
thing Fixity
fixity =
if Fixity
fixity forall a. Eq a => a -> a -> Bool
== Fixity
GHC.defaultFixity
then SDoc
O.empty
else forall a. Outputable a => a -> SDoc
O.ppr Fixity
fixity SDoc -> SDoc -> SDoc
O.<+> forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName (forall a. NamedThing a => a -> Name
getName a
thing)