{-# 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

-- GHC imports.
#if 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

-- | 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 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
    -- If it doesn't match an extension name, try matching against disabling an extension.
    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
    -- Check if a FlagSpec matches an extension name.
    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

    -- 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 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)
-- 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_ :: 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

-- | 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 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
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(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]

-- | 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
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 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(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

-- | Set an extension and update flags. Return @Nothing@ on success. On failure, return an error
-- message.
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

-- | 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 <- 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

  -- We can't update packages here
  let flags1 :: DynFlags
flags1 = DynFlags
flags0 { packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
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
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags DynFlags
flags2
  forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
flags2

  -- Create the parse errors.
  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(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
        -- Stack appears to duplicate package flags, so we use `nub` to work around this
        [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

-- | 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 <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  PrintUnqualified
unqual <- forall (m :: * -> *). GhcMonad m => m PrintUnqualified
getPrintUnqual
#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

-- | 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 <- 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)
  -- We start handling GHC environment files
  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,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

-- | 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 <- forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
imports
  [InteractiveImport]
context <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  -- If we've imported this implicitly, remove the old import.
  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

      -- If this is a `hiding` import, remove previous non-`hiding` imports.
      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

  -- Replace the context.
  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
    -- Check whether an import is the same as another import (same module).
#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

    -- Check whether an import is an *implicit* import of something.
#if MIN_VERSION_ghc(8,4,0)
    implicitImportOf :: ImportDecl GhcPs -> InteractiveImport -> Bool
#else
    implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
#endif
    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

    -- Check whether an import is hidden.
#if MIN_VERSION_ghc(8,4,0)
    isHiddenImport :: ImportDecl GhcPs -> Bool
#else
    isHiddenImport :: ImportDecl RdrName -> Bool
#endif
    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

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)

-- | 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 <- 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
      -- Get all class instances
      ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hscEnv
      ([ClsInst]
clsInsts, [FamInst]
famInsts) = InteractiveContext -> ([ClsInst], [FamInst])
ic_instances InteractiveContext
ic
      -- Remove duplicates
      clsInsts' :: [ClsInst]
clsInsts' = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ClsInst -> ClsInst -> Bool
instEq [ClsInst]
clsInsts
  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
    -- 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 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))


-- | 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
#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

-- | 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 = 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

-- | 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
  [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

  -- Filter out types that have parents in the same set. GHCi also does this.
  let infos :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
infos = forall a. [Maybe a] -> [a]
catMaybes [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
maybeInfos
      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

  -- Print nicely
  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)