{-# LANGUAGE NoImplicitPrelude, CPP #-}

module IHaskell.Eval.Util (
    -- * Initialization
    initGhci,

    -- * Flags and extensions ** Set and unset flags.
    extensionFlag,
    setExtension,
    ExtFlag(..),
    setFlags,
    setWayDynFlag,

    -- * Code Evaluation
    evalImport,
    removeImport,
    evalDeclarations,
    getType,
    getDescription,

    -- * Pretty printing
    doc,
    pprDynFlags,
    pprLanguages,

    -- * Monad-loops
    unfoldM,
    ) where

import           IHaskellPrelude
#if MIN_VERSION_ghc(8,6,0)
#else
import qualified Data.ByteString.Char8 as CBS
#endif

import           Control.Monad.Trans.State

-- GHC imports.
#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)
#else
import           CmdLineParser (warnMsg)
#endif

import           GHC.LanguageExtensions

type ExtensionFlag = Extension

-- | A extension flag that can be set or unset.
data ExtFlag = SetFlag ExtensionFlag
             | UnsetFlag ExtensionFlag

-- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via
-- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@.
extensionFlag :: String         -- Extension name, such as @"DataKinds"@
              -> Maybe ExtFlag
extensionFlag :: String -> Maybe ExtFlag
extensionFlag String
ext =
  case (FlagSpec Extension -> Bool)
-> [FlagSpec Extension] -> Maybe (FlagSpec Extension)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> FlagSpec Extension -> Bool
forall {flag}. String -> FlagSpec flag -> Bool
flagMatches String
ext) [FlagSpec Extension]
xFlags of
    Just FlagSpec Extension
fs -> ExtFlag -> Maybe ExtFlag
forall a. a -> Maybe a
Just (ExtFlag -> Maybe ExtFlag) -> ExtFlag -> Maybe ExtFlag
forall a b. (a -> b) -> a -> b
$ Extension -> ExtFlag
SetFlag (Extension -> ExtFlag) -> Extension -> ExtFlag
forall a b. (a -> b) -> a -> b
$ FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
fs
    -- If it doesn't match an extension name, try matching against disabling an extension.
    Maybe (FlagSpec Extension)
Nothing ->
      case (FlagSpec Extension -> Bool)
-> [FlagSpec Extension] -> Maybe (FlagSpec Extension)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> FlagSpec Extension -> Bool
forall {flag}. String -> FlagSpec flag -> Bool
flagMatchesNo String
ext) [FlagSpec Extension]
xFlags of
        Just FlagSpec Extension
fs -> ExtFlag -> Maybe ExtFlag
forall a. a -> Maybe a
Just (ExtFlag -> Maybe ExtFlag) -> ExtFlag -> Maybe ExtFlag
forall a b. (a -> b) -> a -> b
$ Extension -> ExtFlag
UnsetFlag (Extension -> ExtFlag) -> Extension -> ExtFlag
forall a b. (a -> b) -> a -> b
$ FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
fs
        Maybe (FlagSpec Extension)
Nothing -> Maybe ExtFlag
forall a. Maybe a
Nothing
  where
    -- Check if a FlagSpec matches an extension name.
    flagMatches :: String -> FlagSpec flag -> Bool
flagMatches String
ex FlagSpec flag
fs = String
ex String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
fs

    -- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
    flagMatchesNo :: String -> FlagSpec flag -> Bool
flagMatchesNo String
ex FlagSpec flag
fs = String
ex String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"No" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
fs

#if MIN_VERSION_ghc(9,2,0)
-- Taken from GHC
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_ = addWay w (targetWays_ dflags0) }
      dflags2 :: DynFlags
dflags2 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = (GeneralFlag -> DynFlags -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
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

-- | Consult the RTS to find if GHC has been built with dynamic linking and then turn on the
-- dynamic way for GHC. Otherwise it does nothing.
setWayDynFlag :: DynFlags
              -> DynFlags
setWayDynFlag :: DynFlags -> DynFlags
setWayDynFlag =
  if Bool
hostIsDynamic
  then Way -> DynFlags -> DynFlags
addWay' Way
WayDyn
  else DynFlags -> DynFlags
forall a. a -> a
id
#if MIN_VERSION_ghc(9,0,0)
#else
  where
    hostIsDynamic = dynamicGhc
#endif

-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags :: Bool       -- ^ Whether to include flags which are on by default
            -> DynFlags
            -> O.SDoc
pprDynFlags :: Bool -> DynFlags -> SDoc
pprDynFlags Bool
show_all DynFlags
dflags =
  [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat
    [ String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"GHCi-specific dynamic flag settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((FlagSpec GeneralFlag -> SDoc) -> [FlagSpec GeneralFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((GeneralFlag -> DynFlags -> Bool) -> FlagSpec GeneralFlag -> SDoc
forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting GeneralFlag -> DynFlags -> Bool
opt) [FlagSpec GeneralFlag]
ghciFlags))
    , String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"other dynamic, non-language, flag settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((FlagSpec GeneralFlag -> SDoc) -> [FlagSpec GeneralFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((GeneralFlag -> DynFlags -> Bool) -> FlagSpec GeneralFlag -> SDoc
forall {flag}. (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting GeneralFlag -> DynFlags -> Bool
opt) [FlagSpec GeneralFlag]
others))
    , String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"warning settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((FlagSpec WarningFlag -> SDoc) -> [FlagSpec WarningFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((WarningFlag -> DynFlags -> Bool) -> FlagSpec WarningFlag -> SDoc
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
forall doc. IsOutput doc => doc
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 = FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
        f :: flag
f = FlagSpec flag -> flag
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 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_on

#if MIN_VERSION_ghc(9,6,0)
    default_dflags :: DynFlags
default_dflags = Settings -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags)
#elif MIN_VERSION_ghc(8,10,0)
    default_dflags = defaultDynFlags (settings dflags) (llvmConfig dflags)
#elif MIN_VERSION_ghc(8,6,0)
    default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags)
#else
    default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags)
#endif

    fstr, fnostr :: String -> O.SDoc
    fstr :: String -> SDoc
fstr String
str = String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"-f" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
str

    fnostr :: String -> SDoc
fnostr String
str = String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"-fno-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
str

    ([FlagSpec GeneralFlag]
ghciFlags, [FlagSpec GeneralFlag]
others) = (FlagSpec GeneralFlag -> Bool)
-> [FlagSpec GeneralFlag]
-> ([FlagSpec GeneralFlag], [FlagSpec GeneralFlag])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\FlagSpec GeneralFlag
f -> FlagSpec GeneralFlag -> GeneralFlag
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec GeneralFlag
f GeneralFlag -> [GeneralFlag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GeneralFlag]
flgs) [FlagSpec GeneralFlag]
DynFlags.fFlags

    flgs :: [GeneralFlag]
flgs = [[GeneralFlag]] -> [GeneralFlag]
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]

-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of
-- `ghc-bin`)
pprLanguages :: Bool      -- ^ Whether to include flags which are on by default
             -> DynFlags
             -> O.SDoc
pprLanguages :: Bool -> DynFlags -> SDoc
pprLanguages Bool
show_all DynFlags
dflags =
  [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat
    [ String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"base language is: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<>
      case DynFlags -> Maybe Language
language DynFlags
dflags of
        Maybe Language
Nothing          -> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"Haskell2010"
        Just Language
Haskell98   -> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"Haskell98"
        Just Language
Haskell2010 -> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"Haskell2010"
#if MIN_VERSION_ghc(9,4,0)
        Just Language
GHC2021 -> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"GHC2021"
#else
#endif
    , (if Bool
show_all
         then String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"all active language options:"
         else String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"with the following modifiers:") SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      Int -> SDoc -> SDoc
O.nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((FlagSpec Extension -> SDoc) -> [FlagSpec Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((Extension -> DynFlags -> Bool) -> FlagSpec Extension -> SDoc
forall {doc} {flag}.
IsLine doc =>
(flag -> DynFlags -> Bool) -> FlagSpec flag -> doc
setting Extension -> DynFlags -> Bool
xopt) [FlagSpec Extension]
DynFlags.xFlags))
    ]
  where
    setting :: (flag -> DynFlags -> Bool) -> FlagSpec flag -> doc
setting flag -> DynFlags -> Bool
test FlagSpec flag
flag
      | Bool
quiet = doc
forall doc. IsOutput doc => doc
O.empty
      | Bool
is_on = String -> doc
forall doc. IsLine doc => String -> doc
O.text String
"-X" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
O.<> String -> doc
forall doc. IsLine doc => String -> doc
O.text String
name
      | Bool
otherwise = String -> doc
forall doc. IsLine doc => String -> doc
O.text String
"-XNo" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
O.<> String -> doc
forall doc. IsLine doc => String -> doc
O.text String
name
      where
        name :: String
name = FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
        f :: flag
f = FlagSpec flag -> flag
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 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_on

    default_dflags :: DynFlags
default_dflags =
#if MIN_VERSION_ghc(9,6,0)
      Settings -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) DynFlags -> Maybe Language -> DynFlags
`lang_set`
#elif MIN_VERSION_ghc(8,10,0)
      defaultDynFlags (settings dflags) (llvmConfig dflags) `lang_set`
#elif MIN_VERSION_ghc(8,6,0)
      defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags) `lang_set`
#else
      defaultDynFlags (settings dflags) (llvmTargets dflags) `lang_set`
#endif
      case DynFlags -> Maybe Language
language DynFlags
dflags of
        Maybe Language
Nothing -> Language -> Maybe Language
forall a. a -> Maybe a
Just Language
Haskell2010
        Maybe Language
other   -> Maybe Language
other

-- | Set an extension and update flags. Return @Nothing@ on success. On failure, return an error
-- message.
setExtension :: String -> StateT DynFlags IO (Maybe String)
setExtension :: String -> StateT DynFlags IO (Maybe String)
setExtension String
ext = do
  case String -> Maybe ExtFlag
extensionFlag String
ext of
    Maybe ExtFlag
Nothing -> Maybe String -> StateT DynFlags IO (Maybe String)
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> StateT DynFlags IO (Maybe String))
-> Maybe String -> StateT DynFlags IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Could not parse extension name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext
    Just ExtFlag
flag -> do
      (DynFlags -> DynFlags) -> StateT DynFlags IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((DynFlags -> DynFlags) -> StateT DynFlags IO ())
-> (DynFlags -> DynFlags) -> StateT DynFlags IO ()
forall a b. (a -> b) -> a -> b
$ \DynFlags
flags ->
        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
      Maybe String -> StateT DynFlags IO (Maybe String)
forall a. a -> StateT DynFlags IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

-- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs
-- (newDynFlags). It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String]
setFlags :: forall (m :: * -> *). GhcMonad m => [String] -> m [String]
setFlags [String]
ext = do
  -- Try to parse flags.
  DynFlags
flags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  (DynFlags
flags0, [Located String]
unrecognized, [Warn]
warnings) <- Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags Logger
logger DynFlags
flags ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall e. e -> Located e
noLoc [String]
ext)
#else
  (flags0, unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
#endif

  -- We can't update packages here
  let flags1 :: DynFlags
flags1 = DynFlags
flags0 { packageFlags = packageFlags flags }

#if MIN_VERSION_ghc(9,2,0)
  -- Loading plugins explicitly is no longer required in 9.2
  let flags2 :: DynFlags
flags2 = DynFlags
flags1
#elif MIN_VERSION_ghc(8,6,0)
  -- Plugins were introduced in 8.6
  hsc_env <- GHC.getSession
  flags2 <- liftIO (initializePlugins hsc_env flags1)
#else
  let flags2 = flags1
#endif
  Bool
_ <- DynFlags -> m Bool
forall (m :: * -> *). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags DynFlags
flags2
  DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
flags2

  -- Create the parse errors.
  let noParseErrs :: [String]
noParseErrs = (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"Could not parse: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (Located String -> String) -> Located String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> String
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) ++
#else
      allWarns :: [String]
allWarns = (Warn -> String) -> [Warn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Located String -> String
forall l e. GenLocated l e -> e
unLoc (Located String -> String)
-> (Warn -> Located String) -> Warn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warn -> Located String
warnMsg) [Warn]
warnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
#endif
        -- Stack appears to duplicate package flags, so we use `nub` to work around this
        [String
"-package not supported yet" | [PackageFlag] -> [PackageFlag]
forall a. Eq a => [a] -> [a]
nub (DynFlags -> [PackageFlag]
packageFlags DynFlags
flags) [PackageFlag] -> [PackageFlag] -> Bool
forall a. Eq a => a -> a -> Bool
/= [PackageFlag] -> [PackageFlag]
forall a. Eq a => [a] -> [a]
nub (DynFlags -> [PackageFlag]
packageFlags DynFlags
flags0)]
      warnErrs :: [String]
warnErrs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
allWarns
  [String] -> m [String]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String]
noParseErrs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
warnErrs

-- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but
-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- gives a configurable width of output.
doc :: GhcMonad m => O.SDoc -> m String
doc :: forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc SDoc
sdoc = do
  DynFlags
flags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,6,0)
  let unqual :: NamePprCtx
unqual = NamePprCtx
O.neverQualify
#else
  unqual <- getPrintUnqual
#endif
#if MIN_VERSION_ghc(9,0,0)
  let style :: PprStyle
style = NamePprCtx -> Depth -> PprStyle
O.mkUserStyle NamePprCtx
unqual Depth
O.AllTheWay
#else
  let style = O.mkUserStyle flags 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)
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Mode
-> Int
-> Float
-> (TextDetails -> String -> String)
-> String
-> Doc
-> String
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

-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn
-- flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module.
--
-- We also require that the sandbox PackageConf (if any) is passed here
-- as setSessionDynFlags will read the package database the first time
-- (and only the first time) it is called.
initGhci :: GhcMonad m => Maybe String -> m ()
initGhci :: forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhci Maybe String
sandboxPackages = do
  -- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
#if MIN_VERSION_ghc(9,2,0)
  -- We start handling GHC environment files
  DynFlags
originalFlagsNoPackageEnv <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  DynFlags
originalFlags <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger DynFlags
originalFlagsNoPackageEnv
#elif MIN_VERSION_ghc(9,0,0)
  -- We start handling GHC environment files
  originalFlagsNoPackageEnv <- getSessionDynFlags
  originalFlags <- liftIO $ interpretPackageEnv originalFlagsNoPackageEnv
#else
  originalFlags <- getSessionDynFlags
#endif
  let flag :: Extension -> DynFlags -> DynFlags
flag = (DynFlags -> Extension -> DynFlags)
-> Extension -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Extension -> DynFlags
xopt_set
      unflag :: Extension -> DynFlags -> DynFlags
unflag = (DynFlags -> Extension -> DynFlags)
-> Extension -> DynFlags -> DynFlags
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 (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> DynFlags -> DynFlags
unflag Extension
MonomorphismRestriction (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setWayDynFlag DynFlags
originalFlags
      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 (PkgDbRef -> PackageDBFlag) -> PkgDbRef -> PackageDBFlag
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 [PackageDBFlag] -> [PackageDBFlag] -> [PackageDBFlag]
forall a. [a] -> [a] -> [a]
++ [PackageDBFlag
pkg]

  m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> m ()) -> DynFlags -> m ()
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 = Interpreter
#else
    { hscTarget = HscInterpreted
#endif
    , ghcLink = LinkInMemory
    , pprCols = 300
    , packageDBFlags = pkgFlags
    }

-- | Evaluate a single import statement. If this import statement is importing a module which was
-- previously imported implicitly (such as `Prelude`) or if this module has a `hiding` annotation,
-- the previous import is removed.
evalImport :: GhcMonad m => String -> m ()
evalImport :: forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
imports = do
  ImportDecl GhcPs
importDecl <- String -> m (ImportDecl GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
imports
  [InteractiveImport]
context <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  -- If we've imported this implicitly, remove the old import.
  let noImplicit :: [InteractiveImport]
noImplicit = (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InteractiveImport -> Bool) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> InteractiveImport -> Bool
implicitImportOf ImportDecl GhcPs
importDecl) [InteractiveImport]
context

      -- If this is a `hiding` import, remove previous non-`hiding` imports.
      oldImps :: [InteractiveImport]
oldImps = if ImportDecl GhcPs -> Bool
isHiddenImport ImportDecl GhcPs
importDecl
                  then (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InteractiveImport -> Bool) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> InteractiveImport -> Bool
importOf ImportDecl GhcPs
importDecl) [InteractiveImport]
context
                  else [InteractiveImport]
noImplicit

  -- Replace the context.
  [InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport] -> m ()) -> [InteractiveImport] -> m ()
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
importDecl InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: [InteractiveImport]
oldImps

  where
    -- Check whether an import is the same as another import (same module).
    importOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
    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)
      (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ModuleName -> ModuleName -> Bool)
-> (ImportDecl GhcPs -> ModuleName)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> XRec GhcPs ModuleName
ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName)) ImportDecl GhcPs
decl ImportDecl GhcPs
imp Bool -> Bool -> Bool
&& Bool -> Bool
not (ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDeclQualifiedStyle -> Bool)
-> ImportDeclQualifiedStyle -> Bool
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
decl)
#else
      ((==) `on` (unLoc . ideclName)) decl imp && not (ideclQualified decl)
#endif

    -- Check whether an import is an *implicit* import of something.
#if MIN_VERSION_ghc(9,6,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) = XImportDeclPass -> Bool
ideclImplicit (ImportDecl GhcPs -> XCImportDecl GhcPs
forall pass. ImportDecl pass -> XCImportDecl pass
ideclExt ImportDecl GhcPs
decl) Bool -> Bool -> Bool
&& ImportDecl GhcPs
imp ImportDecl GhcPs -> InteractiveImport -> Bool
`importOf` ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
decl
#else
    implicitImportOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
    implicitImportOf _ (IIModule _) = False
    implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl
#endif

    -- Check whether an import is hidden.
#if MIN_VERSION_ghc(9,6,0)
    isHiddenImport :: ImportDecl GhcPs -> Bool
    isHiddenImport :: ImportDecl GhcPs -> Bool
isHiddenImport ImportDecl GhcPs
imp =
      case ImportDecl GhcPs
-> Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList ImportDecl GhcPs
imp of
        Just (ImportListInterpretation
EverythingBut, XRec GhcPs [LIE GhcPs]
_) -> Bool
True
        Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
_              -> Bool
False
#else
    isHiddenImport :: ImportDecl GhcPs -> 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 <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
  let ctx' :: [InteractiveImport]
ctx' = (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InteractiveImport -> Bool) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> InteractiveImport -> Bool
isImportOf (ModuleName -> InteractiveImport -> Bool)
-> ModuleName -> InteractiveImport -> Bool
forall a b. (a -> b) -> a -> b
$ String -> ModuleName
mkModuleName String
modName)) [InteractiveImport]
ctx
  [InteractiveImport] -> m ()
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 ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mName
    isImportOf ModuleName
name (IIDecl ImportDecl GhcPs
impDecl) = ModuleName
name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
impDecl)

-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations :: forall (m :: * -> *). GhcMonad m => String -> m [String]
evalDeclarations String
decl = do
  [Name]
names <- String -> m [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls String
decl
  m ()
forall (m :: * -> *). GhcMonad m => m ()
cleanUpDuplicateInstances
  DynFlags
flags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
  [String] -> m [String]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String -> String
replace String
":Interactive." String
"" (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Name -> String
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 = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hscEnv ->
  let
      -- Get all class instances
      ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hscEnv
      (InstEnv
clsInsts, [FamInst]
famInsts) = InteractiveContext -> (InstEnv, [FamInst])
ic_instances InteractiveContext
ic
      -- Remove duplicates
#if MIN_VERSION_ghc(9,4,0)
      clsInsts' :: InstEnv
clsInsts' = [ClsInst] -> InstEnv
mkInstEnv ([ClsInst] -> InstEnv) -> [ClsInst] -> InstEnv
forall a b. (a -> b) -> a -> b
$ (ClsInst -> ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ClsInst -> ClsInst -> Bool
instEq ([ClsInst] -> [ClsInst]) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [ClsInst]
instEnvElts InstEnv
clsInsts
#else
      clsInsts' = nubBy instEq clsInsts
#endif
  in HscEnv
hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } }
  where
    instEq :: ClsInst -> ClsInst -> Bool
    -- Only support replacing instances on GHC 7.8 and up
    instEq :: ClsInst -> ClsInst -> Bool
instEq ClsInst
c1 ClsInst
c2 =
      ClsInst -> Class
is_cls ClsInst
c1 Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== ClsInst -> Class
is_cls ClsInst
c2 Bool -> Bool -> Bool
&& Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe Subst
tcMatchTys (ClsInst -> [Type]
is_tys ClsInst
c1) (ClsInst -> [Type]
is_tys ClsInst
c2))


-- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String
getType :: forall (m :: * -> *). GhcMonad m => String -> m String
getType String
expr = do
  Type
result <- TcRnExprMode -> String -> m Type
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
exprType TcRnExprMode
TM_Inst String
expr
  DynFlags
flags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,2,0)
  let typeStr :: String
typeStr = DynFlags -> SDoc -> String
showSDoc DynFlags
flags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Type
result
#else
  let typeStr = O.showSDocUnqual flags $ O.ppr result
#endif
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
typeStr

-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- just add the package dependency instead of copying more code from it.
unfoldM :: IO (Maybe a) -> IO [a]
unfoldM :: forall a. IO (Maybe a) -> IO [a]
unfoldM IO (Maybe a)
f = IO [a] -> (a -> IO [a]) -> Maybe a -> IO [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) (\a
r -> (a
r a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe a) -> IO [a]
forall a. IO (Maybe a) -> IO [a]
unfoldM IO (Maybe a)
f) (Maybe a -> IO [a]) -> IO (Maybe a) -> IO [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe a)
f

-- | A wrapper around @getInfo@. Return info about each name in the string.
getDescription :: GhcMonad m => String -> m [String]
getDescription :: forall (m :: * -> *). GhcMonad m => String -> m [String]
getDescription String
str = do
  NonEmpty Name
names <- String -> m (NonEmpty Name)
forall (m :: * -> *). GhcMonad m => String -> m (NonEmpty Name)
parseName String
str
  NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
maybeInfos <- (Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> NonEmpty Name
-> m (NonEmpty
        (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo' NonEmpty Name
names

  -- Filter out types that have parents in the same set. GHCi also does this.
#if MIN_VERSION_ghc(9,6,0)
  let infos :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos = [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
 -> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)])
-> [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. NonEmpty a -> [a]
nonEmptyToList NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
maybeInfos
#else
  let infos = catMaybes maybeInfos
#endif
      allNames :: NameSet
allNames = [Name] -> NameSet
mkNameSet ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$ ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> Name)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyThing -> Name
forall a. NamedThing a => a -> Name
getName (TyThing -> Name)
-> ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> TyThing)
-> (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> TyThing
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 ((TyThing, b, c, d, e) -> TyThing
forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> a
getInfoType (TyThing, b, c, d, e)
info) of
          Just TyThing
parent -> TyThing -> Name
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 = ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> Bool)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> Bool)
-> (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> Bool
forall {b} {c} {d} {e}. (TyThing, b, c, d, e) -> Bool
hasParent) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos

  -- Print nicely
  ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> m String)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SDoc -> m String
forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc (SDoc -> m String)
-> ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc)
-> (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc
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' = Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
getInfo Bool
False
    getInfoType :: (a, b, c, d, e) -> a
getInfoType (a
theType, b
_, c
_, d
_, e
_) = a
theType
    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
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      TyThing -> Fixity -> SDoc
forall {a}. NamedThing a => a -> Fixity -> SDoc
showFixity TyThing
thing Fixity
fixity SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
GHC.pprInstance [ClsInst]
classInstances) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
O.$$
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
O.vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
GHC.pprFamInst [FamInst]
famInstances)
    showFixity :: a -> Fixity -> SDoc
showFixity a
thing Fixity
fixity =
      if Fixity
fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
GHC.defaultFixity
        then SDoc
forall doc. IsOutput doc => doc
O.empty
        else Fixity -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Fixity
fixity SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> Name -> SDoc
forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName (a -> Name
forall a. NamedThing a => a -> Name
getName a
thing)