{-# LANGUAGE NoOverloadedStrings, NoImplicitPrelude, TypeSynonymInstances, GADTs, CPP #-}

{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
                   a statement, declaration, import, or directive.

This module exports all functions used for evaluation of IHaskell input.
-}
module IHaskell.Eval.Evaluate (
    interpret,
    testInterpret,
    testEvaluate,
    evaluate,
    flushWidgetMessages,
    Interpreter,
    liftIO,
    typeCleaner,
    formatType,
    capturedIO,
    ) where

import           IHaskellPrelude

import           Control.Concurrent (forkIO, threadDelay)
import           Data.Foldable (foldMap)
import           Prelude (head, tail, last, init)
import qualified Data.Set as Set
import           Data.Char as Char
import           Data.Dynamic
import qualified Data.Binary as Binary
import           System.Directory
import           System.Posix.IO (fdToHandle)
import           System.IO (hGetChar, hSetEncoding, utf8)
import           System.Random (getStdGen, randomRs)
import           System.Process
import           System.Exit
import           System.Environment (getEnv)

#if MIN_VERSION_ghc(9,4,0)
import qualified GHC.Runtime.Debugger as Debugger
import           GHC.Runtime.Eval
import           GHC.Driver.Session
import           GHC.Unit.State
import           Control.Monad.Catch as MC
import           GHC.Utils.Outputable hiding ((<>))
import           GHC.Data.Bag
import           GHC.Driver.Backend
import           GHC.Driver.Env
import           GHC.Driver.Ppr
import           GHC.Runtime.Context
import           GHC.Types.Error
import           GHC.Types.SourceError
import           GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#elif MIN_VERSION_ghc(9,2,0)
import qualified GHC.Runtime.Debugger as Debugger
import           GHC.Runtime.Eval
import           GHC.Driver.Session
import           GHC.Unit.State
import           Control.Monad.Catch as MC
import           GHC.Utils.Outputable hiding ((<>))
import           GHC.Data.Bag
import           GHC.Driver.Backend
import           GHC.Driver.Ppr
import           GHC.Runtime.Context
import           GHC.Types.SourceError
import           GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#elif MIN_VERSION_ghc(9,0,0)
import qualified GHC.Runtime.Debugger as Debugger
import           GHC.Runtime.Eval
import           GHC.Driver.Session
import           GHC.Driver.Types
import           GHC.Unit.State
import           Control.Monad.Catch as MC
import           GHC.Utils.Outputable hiding ((<>))
import           GHC.Data.Bag
import           GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#else
import qualified Debugger
import           Bag
import           DynFlags
import           HscTypes
import           InteractiveEval
import           Exception hiding (evaluate)
import           GhcMonad (liftIO)
import           Outputable hiding ((<>))
import           Packages
import qualified ErrUtils
#endif

import qualified GHC.Paths
import           GHC hiding (Stmt, TypeSig)

import           IHaskell.CSS (ihaskellCSS)
import           IHaskell.Types
import           IHaskell.IPython
import           IHaskell.Eval.Parser
import           IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle
import           IHaskell.Eval.Util
import           IHaskell.BrokenPackages
import           StringUtils (replace, split, strip, rstrip)

#ifdef USE_HLINT
import           IHaskell.Eval.Lint
#endif

#if MIN_VERSION_ghc(8,4,0)
import qualified Data.Text as Text
import           IHaskell.Eval.Evaluate.HTML (htmlify)
#endif

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Data.FastString
#elif MIN_VERSION_ghc(8,2,0)
import           FastString (unpackFS)
#else
import           Paths_ihaskell (version)
import           Data.Version (versionBranch)
#endif

#if MIN_VERSION_ghc(9,2,0)
showSDocUnqual :: DynFlags -> SDoc -> String
showSDocUnqual :: DynFlags -> SDoc -> String
showSDocUnqual = DynFlags -> SDoc -> String
showSDoc
#endif

#if MIN_VERSION_ghc(9,0,0)
gcatch :: Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch :: forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MC.catch

gtry :: IO a -> IO (Either SomeException a)
gtry :: forall a. IO a -> IO (Either SomeException a)
gtry = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try

gfinally :: Ghc a -> Ghc b -> Ghc a
gfinally :: forall a b. Ghc a -> Ghc b -> Ghc a
gfinally = forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
MC.finally

ghandle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a
ghandle :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle

throw :: SomeException -> Ghc a
throw :: forall a. SomeException -> Ghc a
throw = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MC.throwM
#endif


-- | Set GHC's verbosity for debugging
ghcVerbosity :: Maybe Int
ghcVerbosity :: Maybe LineNumber
ghcVerbosity = forall a. Maybe a
Nothing -- Just 5

ignoreTypePrefixes :: [String]
ignoreTypePrefixes :: [String]
ignoreTypePrefixes = [ String
"GHC.Types"
                     , String
"GHC.Base"
                     , String
"GHC.Show"
                     , String
"System.IO"
                     , String
"GHC.Float"
                     , String
":Interactive"
                     , String
"GHC.Num"
                     , String
"GHC.IO"
                     , String
"GHC.Integer.Type"
                     ]

typeCleaner :: String -> String
typeCleaner :: String -> String
typeCleaner = String -> String
useStringType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String -> String
`replace` String
"") [String]
fullPrefixes)
  where
    fullPrefixes :: [String]
fullPrefixes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
".") [String]
ignoreTypePrefixes
    useStringType :: String -> String
useStringType = String -> String -> String -> String
replace String
"[Char]" String
"String"

-- MonadIO constraint necessary for GHC 7.6
write :: (MonadIO m, GhcMonad m) => KernelState -> String -> m ()
write :: forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
x = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KernelState -> Bool
kernelDebug KernelState
state) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"DEBUG: " forall a. [a] -> [a] -> [a]
++ String
x

type Interpreter = Ghc

requiredGlobalImports :: [String]
requiredGlobalImports :: [String]
requiredGlobalImports =
  [ String
"import qualified Prelude as IHaskellPrelude"
  , String
"import qualified System.Directory as IHaskellDirectory"
  , String
"import qualified System.Posix.IO as IHaskellIO"
  , String
"import qualified System.IO as IHaskellSysIO"
  , String
"import qualified Language.Haskell.TH as IHaskellTH"
  ]

ihaskellGlobalImports :: [String]
ihaskellGlobalImports :: [String]
ihaskellGlobalImports =
  [ String
"import IHaskell.Display()"
  , String
"import qualified IHaskell.Display"
  , String
"import qualified IHaskell.IPython.Stdin"
  , String
"import qualified IHaskell.Eval.Widgets"
  ]

hiddenPackageNames :: Set.Set String
hiddenPackageNames :: Set String
hiddenPackageNames = forall a. Ord a => [a] -> Set a
Set.fromList [String
"ghc-lib", String
"ghc-lib-parser"]

-- | Interpreting function for testing.
testInterpret :: Interpreter a -> IO a
testInterpret :: forall a. Interpreter a -> IO a
testInterpret Interpreter a
v = forall a. String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
interpret String
GHC.Paths.libdir Bool
False Bool
False (forall a b. a -> b -> a
const Interpreter a
v)

-- | Evaluation function for testing.
testEvaluate :: String -> IO ()
testEvaluate :: String -> IO ()
testEvaluate String
str = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Interpreter a -> IO a
testInterpret forall a b. (a -> b) -> a -> b
$
  KernelState
-> String
-> Publisher
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter (KernelState, ErrorOccurred)
evaluate KernelState
defaultKernelState String
str (\EvaluationResult
_ ErrorOccurred
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\KernelState
state [WidgetMsg]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state)

-- | Run an interpreting action. This is effectively runGhc with initialization
-- and importing. The `allowedStdin` argument indicates whether `stdin` is
-- handled specially, which cannot be done in a testing environment. The
-- `needsSupportLibraries` argument indicates whether we want support libraries
-- to be imported, which is not the case during testing. The argument passed to
-- the action indicates whether the IHaskell library is available.
interpret :: String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
interpret :: forall a. String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
interpret String
libdir Bool
allowedStdin Bool
needsSupportLibraries Bool -> Interpreter a
action = forall a. Maybe String -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just String
libdir) forall a b. (a -> b) -> a -> b
$ do
  -- If we're in a sandbox, add the relevant package database
  Maybe String
sandboxPackages <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe String)
getSandboxPackageConf
  forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhci Maybe String
sandboxPackages
  case Maybe LineNumber
ghcVerbosity of
    Just LineNumber
verb -> do
      DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      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 { verbosity :: LineNumber
verbosity = LineNumber
verb }
    Maybe LineNumber
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Bool
hasSupportLibraries <- Bool -> Interpreter Bool
initializeImports Bool
needsSupportLibraries

  -- Close stdin so it can't be used. Otherwise it'll block the kernel forever.
  String
dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getIHaskellDir
  let cmd :: String
cmd = forall r. PrintfType r => String -> r
printf String
"IHaskell.IPython.Stdin.fixStdin \"%s\"" String
dir
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
allowedStdin Bool -> Bool -> Bool
&& Bool
hasSupportLibraries) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
cmd ExecOptions
execOptions

  Ghc ()
initializeItVariable

  -- Run the rest of the interpreter
  Bool -> Interpreter a
action Bool
hasSupportLibraries

#if MIN_VERSION_ghc(9,4,0)
packageIdString' :: Logger -> DynFlags -> HscEnv -> UnitInfo -> IO String
packageIdString' logger dflags hsc_env pkg_cfg = do
    (_, unitState, _, _) <- initUnits logger dflags Nothing (hsc_all_home_unit_ids hsc_env)
    case (lookupUnit unitState $ mkUnit pkg_cfg) of
      Nothing -> pure "(unknown)"
      Just cfg -> let
        PackageName name = unitPackageName cfg
        in pure $ unpackFS name
#elif MIN_VERSION_ghc(9,2,0)
packageIdString' :: Logger -> DynFlags -> UnitInfo -> IO String
packageIdString' :: Logger -> DynFlags -> GenUnitInfo UnitId -> IO String
packageIdString' Logger
logger DynFlags
dflags GenUnitInfo UnitId
pkg_cfg = do
    ([UnitDatabase UnitId]
_, UnitState
unitState, HomeUnit
_, Maybe PlatformConstants
_) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags forall a. Maybe a
Nothing
    case (UnitState -> Unit -> Maybe (GenUnitInfo UnitId)
lookupUnit UnitState
unitState forall a b. (a -> b) -> a -> b
$ GenUnitInfo UnitId -> Unit
mkUnit GenUnitInfo UnitId
pkg_cfg) of
      Maybe (GenUnitInfo UnitId)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"(unknown)"
      Just GenUnitInfo UnitId
cfg -> let
        PackageName FastString
name = forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName GenUnitInfo UnitId
cfg
        in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
name
#elif MIN_VERSION_ghc(9,0,0)
packageIdString' :: DynFlags -> UnitInfo -> String
packageIdString' dflags pkg_cfg =
    case (lookupUnit (unitState dflags) $ mkUnit pkg_cfg) of
      Nothing -> "(unknown)"
      Just cfg -> let
        PackageName name = unitPackageName cfg
        in unpackFS name
#elif MIN_VERSION_ghc(8,2,0)
packageIdString' :: DynFlags -> PackageConfig -> String
packageIdString' dflags pkg_cfg =
    case (lookupPackage dflags $ packageConfigId pkg_cfg) of
      Nothing -> "(unknown)"
      Just cfg -> let
        PackageName name = packageName cfg
        in unpackFS name
#else
packageIdString' :: DynFlags -> PackageConfig -> String
packageIdString' dflags pkg_cfg =
    fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg)
#endif

#if MIN_VERSION_ghc(9,4,0)
getPackageConfigs :: Logger -> DynFlags -> HscEnv -> IO [GenUnitInfo UnitId]
getPackageConfigs logger dflags hsc_env = do
    (pkgDb, _, _, _) <- initUnits logger dflags Nothing (hsc_all_home_unit_ids hsc_env)
    pure $ foldMap unitDatabaseUnits pkgDb
#elif MIN_VERSION_ghc(9,2,0)
getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId]
getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId]
getPackageConfigs Logger
logger DynFlags
dflags = do
    ([UnitDatabase UnitId]
pkgDb, UnitState
_, HomeUnit
_, Maybe PlatformConstants
_) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits [UnitDatabase UnitId]
pkgDb
#elif MIN_VERSION_ghc(9,0,0)
getPackageConfigs :: DynFlags -> [GenUnitInfo UnitId]
getPackageConfigs dflags =
    foldMap unitDatabaseUnits pkgDb
  where
    Just pkgDb = unitDatabases dflags
#else
getPackageConfigs :: DynFlags -> [PackageConfig]
getPackageConfigs dflags =
    foldMap snd pkgDb
  where
    Just pkgDb = pkgDatabase dflags
#endif

-- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell
-- library is available.
initializeImports :: Bool -> Interpreter Bool
initializeImports :: Bool -> Interpreter Bool
initializeImports Bool
importSupportLibraries = do
  -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
  -- version of the ihaskell library. Also verify that the packages we load are not broken.
  DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  [String]
broken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getBrokenPackages
#if MIN_VERSION_ghc(9,2,0)
  let dflgs :: DynFlags
dflgs = DynFlags
dflags
#elif MIN_VERSION_ghc(9,0,0)
  dflgs <- liftIO $ initUnits dflags
#else
  (dflgs, _) <- liftIO $ initPackages dflags
#endif

#if MIN_VERSION_ghc(9,4,0)
  logger <- getLogger
  hsc_env <- getSession
  db <- liftIO $ getPackageConfigs logger dflgs hsc_env
  packageNames <- liftIO $ mapM (packageIdString' logger dflgs hsc_env) db
  let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
      hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
      initStr = "ihaskell-"
#elif MIN_VERSION_ghc(9,2,0)
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  [GenUnitInfo UnitId]
db <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO [GenUnitInfo UnitId]
getPackageConfigs Logger
logger DynFlags
dflgs
  [String]
packageNames <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Logger -> DynFlags -> GenUnitInfo UnitId -> IO String
packageIdString' Logger
logger DynFlags
dflgs) [GenUnitInfo UnitId]
db
  let hiddenPackages :: Set String
hiddenPackages = forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set String
hiddenPackageNames (forall a. Ord a => [a] -> Set a
Set.fromList [String]
packageNames)
      hiddenFlags :: [PackageFlag]
hiddenFlags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PackageFlag
HidePackage forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set String
hiddenPackages
      initStr :: String
initStr = String
"ihaskell-"
#else
  let db = getPackageConfigs dflgs
      packageNames = map (packageIdString' dflgs) db
      hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
      hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
      initStr = "ihaskell-"
#endif

#if MIN_VERSION_ghc(8,2,0)
      -- Name of the ihaskell package, i.e. "ihaskell"
      iHaskellPkgName :: String
iHaskellPkgName = String
"ihaskell"
#else
      -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
      iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
#endif

      displayPkgs :: [String]
displayPkgs = [ String
pkgName
                    | String
pkgName <- [String]
packageNames
                    , Just (Char
x:String
_) <- [forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
initStr String
pkgName]
                    , String
pkgName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
broken
                    , Char -> Bool
isAlpha Char
x ]

      hasIHaskellPackage :: Bool
hasIHaskellPackage = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== String
iHaskellPkgName) [String]
packageNames

  -- Generate import statements all Display modules.
  let capitalize :: String -> String
      capitalize :: String -> String
capitalize [] = []
      capitalize (Char
first:String
rest) = Char -> Char
Char.toUpper Char
first forall a. a -> [a] -> [a]
: String
rest

      importFmt :: String
importFmt = String
"import IHaskell.Display.%s"


#if MIN_VERSION_ghc(8,2,0)
      toImportStmt :: String -> String
      toImportStmt :: String -> String
toImportStmt = forall r. PrintfType r => String -> r
printf String
importFmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LineNumber -> [a] -> [a]
drop LineNumber
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
split String
"-"
#else
      dropFirstAndLast :: [a] -> [a]
      dropFirstAndLast = reverse . drop 1 . reverse . drop 1

      toImportStmt :: String -> String
      toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-"
#endif

      displayImports :: [String]
displayImports = forall a b. (a -> b) -> [a] -> [b]
map String -> String
toImportStmt [String]
displayPkgs

  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
dflgs { packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflgs forall a. [a] -> [a] -> [a]
++ [PackageFlag]
hiddenFlags }

#if MIN_VERSION_ghc(9,6,0)
  -- Import implicit prelude.
  importDecl <- parseImportDecl "import Prelude"
  let implicitPrelude = importDecl { ideclExt = (ideclExt importDecl) { ideclImplicit = True } }
#else
  -- Import implicit prelude.
  ImportDecl GhcPs
importDecl <- forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
"import Prelude"
  let implicitPrelude :: ImportDecl GhcPs
implicitPrelude = ImportDecl GhcPs
importDecl { ideclImplicit :: Bool
ideclImplicit = Bool
True }
#endif
      displayImports' :: [String]
displayImports' = if Bool
importSupportLibraries then [String]
displayImports else []

  -- Import modules.
  [ImportDecl GhcPs]
imports <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl forall a b. (a -> b) -> a -> b
$ [String]
requiredGlobalImports forall a. [a] -> [a] -> [a]
++ if Bool
hasIHaskellPackage
                                                               then [String]
ihaskellGlobalImports forall a. [a] -> [a] -> [a]
++ [String]
displayImports'
                                                               else []
  forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
IIDecl forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
implicitPrelude forall a. a -> [a] -> [a]
: [ImportDecl GhcPs]
imports

  forall (m :: * -> *) a. Monad m => a -> m a
return Bool
hasIHaskellPackage

-- | Give a value for the `it` variable.
initializeItVariable :: Interpreter ()
initializeItVariable :: Ghc ()
initializeItVariable =
  -- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist,
  -- the first statement will fail.
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
"let it = ()" ExecOptions
execOptions

-- | Publisher for IHaskell outputs. The first argument indicates whether this output is final
-- (true) or intermediate (false). The second argument indicates whether the evaluation
-- completed successfully (Success) or an error occurred (Failure).
type Publisher = (EvaluationResult -> ErrorOccurred -> IO ())

-- | Output of a command evaluation.
data EvalOut =
       EvalOut
         { EvalOut -> ErrorOccurred
evalStatus :: ErrorOccurred
         , EvalOut -> Display
evalResult :: Display
         , EvalOut -> KernelState
evalState :: KernelState
         , EvalOut -> [DisplayData]
evalPager :: [DisplayData]
         , EvalOut -> [WidgetMsg]
evalMsgs :: [WidgetMsg]
         }

cleanString :: String -> String
cleanString :: String -> String
cleanString String
istr = if Bool
allBrackets
                  then String
clean
                  else String
istr
  where
    str :: String
str = String -> String
strip String
istr
    l :: [String]
l = String -> [String]
lines String
str
    allBrackets :: Bool
allBrackets = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall {t :: * -> *} {p}. Foldable t => t (p -> Bool) -> p -> Bool
fAny [forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
">", forall (t :: * -> *) a. Foldable t => t a -> Bool
null]) [String]
l
    fAny :: t (p -> Bool) -> p -> Bool
fAny t (p -> Bool)
fs p
x = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ p
x) t (p -> Bool)
fs
    clean :: String
clean = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
removeBracket [String]
l
    removeBracket :: String -> String
removeBracket (Char
'>':String
xs) = String
xs
    removeBracket [] = []
    -- should never happen:
    removeBracket String
other = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Expected bracket as first char, but got string: " forall a. [a] -> [a] -> [a]
++ String
other

-- | Evaluate some IPython input code.
evaluate :: KernelState                  -- ^ The kernel state.
         -> String                       -- ^ Haskell code or other interpreter commands.
         -> Publisher                    -- ^ Function used to publish data outputs.
         -> (KernelState -> [WidgetMsg] -> IO KernelState) -- ^ Function to handle widget messages
         -> Interpreter (KernelState, ErrorOccurred)
evaluate :: KernelState
-> String
-> Publisher
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter (KernelState, ErrorOccurred)
evaluate KernelState
kernelState String
code Publisher
output KernelState -> [WidgetMsg] -> IO KernelState
widgetHandler = do
  [Located CodeBlock]
cmds <- String -> Ghc [Located CodeBlock]
parseString (String -> String
cleanString String
code)
  let execCount :: LineNumber
execCount = KernelState -> LineNumber
getExecutionCounter KernelState
kernelState

  -- Extract all parse errors.
  let justError :: CodeBlock -> Maybe CodeBlock
justError x :: CodeBlock
x@ParseError{} = forall a. a -> Maybe a
Just CodeBlock
x
      justError CodeBlock
_ = forall a. Maybe a
Nothing
      errs :: [CodeBlock]
errs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CodeBlock -> Maybe CodeBlock
justError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unloc) [Located CodeBlock]
cmds

  (KernelState
updated, ErrorOccurred
errorOccurred) <- case [CodeBlock]
errs of
               -- Only run things if there are no parse errors.
               [] -> do

#ifdef USE_HLINT
                 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KernelState -> LintStatus
getLintStatus KernelState
kernelState forall a. Eq a => a -> a -> Bool
/= LintStatus
LintOff) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                   Display
lintSuggestions <- String -> [Located CodeBlock] -> IO Display
lint String
code [Located CodeBlock]
cmds
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Display -> Bool
noResults Display
lintSuggestions) forall a b. (a -> b) -> a -> b
$
                     Publisher
output (Display -> [DisplayData] -> [WidgetMsg] -> EvaluationResult
FinalResult Display
lintSuggestions [] []) ErrorOccurred
Success
#endif

                 KernelState
-> [CodeBlock] -> Interpreter (KernelState, ErrorOccurred)
runUntilFailure KernelState
kernelState (forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
unloc [Located CodeBlock]
cmds forall a. [a] -> [a] -> [a]
++ [forall {t}. PrintfArg t => t -> CodeBlock
storeItCommand LineNumber
execCount])
               -- Print all parse errors.
               [CodeBlock]
_ -> do
                 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CodeBlock]
errs forall a b. (a -> b) -> a -> b
$ \CodeBlock
err -> do
                   EvalOut
out <- Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output CodeBlock
err KernelState
kernelState
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Publisher
output
                     (Display -> [DisplayData] -> [WidgetMsg] -> EvaluationResult
FinalResult (EvalOut -> Display
evalResult EvalOut
out) [] [])
                     (EvalOut -> ErrorOccurred
evalStatus EvalOut
out)
                 forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
kernelState, ErrorOccurred
Failure)

  forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
updated { getExecutionCounter :: LineNumber
getExecutionCounter = LineNumber
execCount forall a. Num a => a -> a -> a
+ LineNumber
1 }, ErrorOccurred
errorOccurred)

  where
    noResults :: Display -> Bool
noResults (Display [DisplayData]
res) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DisplayData]
res
    noResults (ManyDisplay [Display]
res) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Display -> Bool
noResults [Display]
res

    runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter (KernelState, ErrorOccurred)
    runUntilFailure :: KernelState
-> [CodeBlock] -> Interpreter (KernelState, ErrorOccurred)
runUntilFailure KernelState
state [] = forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
state, ErrorOccurred
Success)
    runUntilFailure KernelState
state (CodeBlock
cmd:[CodeBlock]
rest) = do
      EvalOut
evalOut <- Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output CodeBlock
cmd KernelState
state

      -- Get displayed channel outputs. Merge them with normal display outputs.
      Maybe Display
dispsMay <- if KernelState -> Bool
supportLibrariesAvailable KernelState
state
                    then do
                      Either String (IO ByteString)
getEncodedDisplays <- forall a. Typeable a => String -> Interpreter (Either String a)
extractValue String
"IHaskell.Display.displayFromChanEncoded"
                      case Either String (IO ByteString)
getEncodedDisplays of
                        Left String
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Deserialization error (Evaluate.hs): " forall a. [a] -> [a] -> [a]
++ String
err
                        Right IO ByteString
displaysIO -> do
                          ByteString
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
displaysIO
                          case forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Binary.decodeOrFail ByteString
result of
                            Left (ByteString
_, ByteOffset
_, String
err) -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Deserialization error (Evaluate.hs): " forall a. [a] -> [a] -> [a]
++ String
err
                            Right (ByteString
_, ByteOffset
_, Maybe Display
res) -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Display
res
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      let result :: Display
result =
            case Maybe Display
dispsMay of
              Maybe Display
Nothing    -> EvalOut -> Display
evalResult EvalOut
evalOut
              Just Display
disps -> EvalOut -> Display
evalResult EvalOut
evalOut forall a. Semigroup a => a -> a -> a
<> Display
disps

      -- Output things only if they are non-empty.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Display -> Bool
noResults Display
result Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EvalOut -> [DisplayData]
evalPager EvalOut
evalOut)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Publisher
output
          (Display -> [DisplayData] -> [WidgetMsg] -> EvaluationResult
FinalResult Display
result (EvalOut -> [DisplayData]
evalPager EvalOut
evalOut) [])
          (EvalOut -> ErrorOccurred
evalStatus EvalOut
evalOut)

      let tempMsgs :: [WidgetMsg]
tempMsgs = EvalOut -> [WidgetMsg]
evalMsgs EvalOut
evalOut
          tempState :: KernelState
tempState = EvalOut -> KernelState
evalState EvalOut
evalOut { evalMsgs :: [WidgetMsg]
evalMsgs = [] }

      -- Handle the widget messages
      KernelState
newState <- if KernelState -> Bool
supportLibrariesAvailable KernelState
state
                    then KernelState
-> [WidgetMsg]
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter KernelState
flushWidgetMessages KernelState
tempState [WidgetMsg]
tempMsgs KernelState -> [WidgetMsg] -> IO KernelState
widgetHandler
                    else forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
tempState

      case EvalOut -> ErrorOccurred
evalStatus EvalOut
evalOut of
        ErrorOccurred
Success -> KernelState
-> [CodeBlock] -> Interpreter (KernelState, ErrorOccurred)
runUntilFailure KernelState
newState [CodeBlock]
rest
        ErrorOccurred
Failure -> forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
newState, ErrorOccurred
Failure)

    storeItCommand :: t -> CodeBlock
storeItCommand t
execCount = String -> CodeBlock
Statement forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"let it%d = it" t
execCount

-- | Compile a string and extract a value from it. Effectively extract the result of an expression
-- from inside the notebook environment.
extractValue :: Typeable a => String -> Interpreter (Either String a)
extractValue :: forall a. Typeable a => String -> Interpreter (Either String a)
extractValue String
expr = do
  Dynamic
compiled <- forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
expr
  case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
compiled of
    Maybe a
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left String
multipleIHaskells)
    Just a
result -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
result)

  where
    multipleIHaskells :: String
multipleIHaskells =
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"The installed IHaskell support libraries do not match"
        , String
" the instance of IHaskell you are running.\n"
        , String
"This *may* cause problems with functioning of widgets or rich media displays.\n"
        , String
"This is most often caused by multiple copies of IHaskell"
        , String
" being installed simultaneously in your environment.\n"
        , String
"To resolve this issue, clear out your environment and reinstall IHaskell.\n"
        , String
"If you are installing support libraries, make sure you only do so once:\n"
        , String
"    # Run this without first running `stack install ihaskell`\n"
        , String
"    stack install ihaskell-diagrams\n"
        , String
"If you continue to have problems, please file an issue on Github."
        ]

flushWidgetMessages :: KernelState
                    -> [WidgetMsg]
                    -> (KernelState -> [WidgetMsg] -> IO KernelState)
                    -> Interpreter KernelState
flushWidgetMessages :: KernelState
-> [WidgetMsg]
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter KernelState
flushWidgetMessages KernelState
state [WidgetMsg]
evalmsgs KernelState -> [WidgetMsg] -> IO KernelState
widgetHandler = do
  -- Capture all widget messages queued during code execution
  Either String (IO [WidgetMsg])
extracted <- forall a. Typeable a => String -> Interpreter (Either String a)
extractValue String
"IHaskell.Eval.Widgets.relayWidgetMessages"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    case Either String (IO [WidgetMsg])
extracted of
      Left String
err -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Disabling IHaskell widget support due to an encountered error:"
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
        forall (m :: * -> *) a. Monad m => a -> m a
return KernelState
state
      Right IO [WidgetMsg]
messagesIO -> do
        [WidgetMsg]
messages <- IO [WidgetMsg]
messagesIO

        -- Handle all the widget messages
        let commMessages :: [WidgetMsg]
commMessages = [WidgetMsg]
evalmsgs forall a. [a] -> [a] -> [a]
++ [WidgetMsg]
messages
        KernelState -> [WidgetMsg] -> IO KernelState
widgetHandler KernelState
state [WidgetMsg]
commMessages

#if MIN_VERSION_ghc(9,6,0)
getErrMsgDoc :: ErrUtils.Diagnostic e => ErrUtils.MsgEnvelope e -> SDoc
getErrMsgDoc = ErrUtils.pprLocMsgEnvelopeDefault
#elif MIN_VERSION_ghc(9,4,0)
getErrMsgDoc :: ErrUtils.Diagnostic e => ErrUtils.MsgEnvelope e -> SDoc
getErrMsgDoc = ErrUtils.pprLocMsgEnvelope
#elif MIN_VERSION_ghc(9,2,0)
getErrMsgDoc :: ErrUtils.WarnMsg -> SDoc
getErrMsgDoc :: WarnMsg -> SDoc
getErrMsgDoc = forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
ErrUtils.pprLocMsgEnvelope
#else
getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc
getErrMsgDoc = ErrUtils.pprLocErrMsg
#endif

safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SomeException -> Interpreter EvalOut
handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SourceError -> Interpreter EvalOut
sourceErrorHandler
  where
    handler :: SomeException -> Interpreter EvalOut
    handler :: SomeException -> Interpreter EvalOut
handler SomeException
exception =
      forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
          , evalResult :: Display
evalResult = String -> Display
displayError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
exception
          , evalState :: KernelState
evalState = KernelState
state
          , evalPager :: [DisplayData]
evalPager = []
          , evalMsgs :: [WidgetMsg]
evalMsgs = []
          }

    sourceErrorHandler :: SourceError -> Interpreter EvalOut
    sourceErrorHandler :: SourceError -> Interpreter EvalOut
sourceErrorHandler SourceError
srcerr = do
#if MIN_VERSION_ghc(9,4,0)
      let msgs = bagToList . getMessages $ srcErrorMessages srcerr
#else
      let msgs :: [WarnMsg]
msgs = forall a. Bag a -> [a]
bagToList forall a b. (a -> b) -> a -> b
$ SourceError -> ErrorMessages
srcErrorMessages SourceError
srcerr
#endif
      [String]
errStrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [WarnMsg]
msgs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarnMsg -> SDoc
getErrMsgDoc

      let fullErr :: String
fullErr = [String] -> String
unlines [String]
errStrs

      forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
          , evalResult :: Display
evalResult = String -> Display
displayError String
fullErr
          , evalState :: KernelState
evalState = KernelState
state
          , evalPager :: [DisplayData]
evalPager = []
          , evalMsgs :: [WidgetMsg]
evalMsgs = []
          }

wrapExecution :: KernelState
              -> Interpreter Display
              -> Interpreter EvalOut
wrapExecution :: KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state Interpreter Display
exec = KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state forall a b. (a -> b) -> a -> b
$
  Interpreter Display
exec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
res ->
    forall (m :: * -> *) a. Monad m => a -> m a
return
      EvalOut
        { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
        , evalResult :: Display
evalResult = Display
res
        , evalState :: KernelState
evalState = KernelState
state
        , evalPager :: [DisplayData]
evalPager = []
        , evalMsgs :: [WidgetMsg]
evalMsgs = []
        }

-- | Return the display data for this command, as well as whether it resulted in an error.
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
_ (Import String
importStr) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Import: " forall a. [a] -> [a] -> [a]
++ String
importStr
  forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
importStr
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

evalCommand Publisher
_ (Module String
contents) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Module:\n" forall a. [a] -> [a] -> [a]
++ String
contents

  -- Write the module contents to a temporary file in our work directory
  [String]
namePieces <- forall (m :: * -> *). GhcMonad m => String -> m [String]
getModuleName String
contents
  let directory :: String
directory = String
"./" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"/" (forall a. [a] -> [a]
init [String]
namePieces) forall a. [a] -> [a] -> [a]
++ String
"/"
      filename :: String
filename = forall a. [a] -> a
last [String]
namePieces forall a. [a] -> [a] -> [a]
++ String
".hs"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
    String -> String -> IO ()
writeFile (String
directory forall a. [a] -> [a] -> [a]
++ String
filename) String
contents

  -- Clear old modules of this name
  let modName :: String
modName = forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
namePieces
  forall (m :: * -> *). GhcMonad m => TargetId -> m ()
removeTarget forall a b. (a -> b) -> a -> b
$ ModuleName -> TargetId
TargetModule forall a b. (a -> b) -> a -> b
$ String -> ModuleName
mkModuleName String
modName
  forall (m :: * -> *). GhcMonad m => TargetId -> m ()
removeTarget forall a b. (a -> b) -> a -> b
$ String -> Maybe Phase -> TargetId
TargetFile String
filename forall a. Maybe a
Nothing

  -- Remember which modules we've loaded before.
  [InteractiveImport]
importedModules <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  let
      -- Get the dot-delimited pieces of the module name.
      moduleNameOf :: InteractiveImport -> [String]
      moduleNameOf :: InteractiveImport -> [String]
moduleNameOf (IIDecl ImportDecl GhcPs
decl) = String -> String -> [String]
split String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
decl
      moduleNameOf (IIModule ModuleName
imp) = String -> String -> [String]
split String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString forall a b. (a -> b) -> a -> b
$ ModuleName
imp

      -- Return whether this module prevents the loading of the one we're trying to load. If a module B
      -- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
      -- However, we *can* just reload a module.
      preventsLoading :: InteractiveImport -> Bool
preventsLoading InteractiveImport
md =
        let pieces :: [String]
pieces = InteractiveImport -> [String]
moduleNameOf InteractiveImport
md
        in forall a. [a] -> a
last [String]
namePieces forall a. Eq a => a -> a -> Bool
== forall a. [a] -> a
last [String]
pieces Bool -> Bool -> Bool
&& [String]
namePieces forall a. Eq a => a -> a -> Bool
/= [String]
pieces

  -- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load
  -- the original *.hs fails and then fails.
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find InteractiveImport -> Bool
preventsLoading [InteractiveImport]
importedModules of
    -- If something prevents loading this module, return an error.
    Just InteractiveImport
previous -> do
      let prevLoaded :: String
prevLoaded = forall a. [a] -> [[a]] -> [a]
intercalate String
"." (InteractiveImport -> [String]
moduleNameOf InteractiveImport
previous)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$
        forall r. PrintfType r => String -> r
printf String
"Can't load module %s because already loaded %s" String
modName String
prevLoaded

    -- Since nothing prevents loading the module, compile and load it.
    Maybe InteractiveImport
Nothing -> String -> String -> Interpreter Display
doLoadModule String
modName String
modName

-- | Directives set via `:set`.
evalCommand Publisher
_output (Directive DirectiveType
SetDynFlag String
flagsStr) KernelState
state = KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"All Flags: " forall a. [a] -> [a] -> [a]
++ String
flagsStr

  -- Find which flags are IHaskell flags, and which are GHC flags
  let flags :: [String]
flags = String -> [String]
words String
flagsStr

      -- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell
      -- flags.
      ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState)
      ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater String
flag = KernelOpt -> KernelState -> KernelState
getUpdateKernelState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
flag forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelOpt -> [String]
getSetName) [KernelOpt]
kernelOpts

      ([String]
ihaskellFlags, [String]
ghcFlags) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater) [String]
flags

  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"IHaskell Flags: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ihaskellFlags
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"GHC Flags: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ghcFlags

  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
flags
    then do
      DynFlags
flgs <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
          , evalResult :: Display
evalResult = [DisplayData] -> Display
Display
                           [ String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
flgs forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                                                        [ Bool -> DynFlags -> SDoc
pprDynFlags Bool
False DynFlags
flgs
                                                        , Bool -> DynFlags -> SDoc
pprLanguages Bool
False DynFlags
flgs
                                                        ]
                           ]
          , evalState :: KernelState
evalState = KernelState
state
          , evalPager :: [DisplayData]
evalPager = []
          , evalMsgs :: [WidgetMsg]
evalMsgs = []
          }
    else do
      -- Apply all IHaskell flag updaters to the state to get the new state
      let state' :: KernelState
state' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater [String]
ihaskellFlags) KernelState
state
      [String]
errs <- forall (m :: * -> *). GhcMonad m => [String] -> m [String]
setFlags [String]
ghcFlags
      let disp :: Display
disp =
            case [String]
errs of
              [] -> forall a. Monoid a => a
mempty
              [String]
_  -> String -> Display
displayError forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
errs

      -- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.
      if String
"-XNoImplicitPrelude" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags
        then forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
"import qualified Prelude as Prelude"
        else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"-XImplicitPrelude" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags) forall a b. (a -> b) -> a -> b
$ do
          ImportDecl GhcPs
importDecl <- forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
"import Prelude"
#if MIN_VERSION_ghc(9,6,0)
          let implicitPrelude = importDecl { ideclExt = (ideclExt importDecl) { ideclImplicit = True } }
#else
          let implicitPrelude :: ImportDecl GhcPs
implicitPrelude = ImportDecl GhcPs
importDecl { ideclImplicit :: Bool
ideclImplicit = Bool
True }
#endif
          [InteractiveImport]
imports <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
          forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
implicitPrelude forall a. a -> [a] -> [a]
: [InteractiveImport]
imports

      forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
          , evalResult :: Display
evalResult = Display
disp
          , evalState :: KernelState
evalState = KernelState
state'
          , evalPager :: [DisplayData]
evalPager = []
          , evalMsgs :: [WidgetMsg]
evalMsgs = []
          }

evalCommand Publisher
output (Directive DirectiveType
SetExtension String
opts) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Extension: " forall a. [a] -> [a] -> [a]
++ String
opts
  let set :: String
set = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
" -X" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
opts
  Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output (DirectiveType -> String -> CodeBlock
Directive DirectiveType
SetDynFlag String
set) KernelState
state

evalCommand Publisher
_output (Directive DirectiveType
LoadModule String
mods) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Load Module: " forall a. [a] -> [a] -> [a]
++ String
mods
  let stripped :: String
stripped@(Char
firstChar:String
remainder) = String
mods
      ([String]
modules, Bool
removeModule) =
        case Char
firstChar of
          Char
'+' -> (String -> [String]
words String
remainder, Bool
False)
          Char
'-' -> (String -> [String]
words String
remainder, Bool
True)
          Char
_   -> (String -> [String]
words String
stripped, Bool
False)

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
modules forall a b. (a -> b) -> a -> b
$ \String
modl -> if Bool
removeModule
                             then forall (m :: * -> *). GhcMonad m => String -> m ()
removeImport String
modl
                             else forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport forall a b. (a -> b) -> a -> b
$ String
"import " forall a. [a] -> [a] -> [a]
++ String
modl

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

evalCommand Publisher
_output (Directive DirectiveType
SetOption String
opts) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Option: " forall a. [a] -> [a] -> [a]
++ String
opts
  let nonExisting :: [String]
nonExisting = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
optionExists) forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
opts
  if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
nonExisting
    then let err :: String
err = String
"No such options: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
nonExisting
         in forall (m :: * -> *) a. Monad m => a -> m a
return
              EvalOut
                { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
                , evalResult :: Display
evalResult = String -> Display
displayError String
err
                , evalState :: KernelState
evalState = KernelState
state
                , evalPager :: [DisplayData]
evalPager = []
                , evalMsgs :: [WidgetMsg]
evalMsgs = []
                }
    else let options :: [KernelOpt]
options = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe KernelOpt
findOption forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
opts
             updater :: KernelState -> KernelState
updater = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map KernelOpt -> KernelState -> KernelState
getUpdateKernelState [KernelOpt]
options
         in forall (m :: * -> *) a. Monad m => a -> m a
return
              EvalOut
                { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
                , evalResult :: Display
evalResult = forall a. Monoid a => a
mempty
                , evalState :: KernelState
evalState = KernelState -> KernelState
updater KernelState
state
                , evalPager :: [DisplayData]
evalPager = []
                , evalMsgs :: [WidgetMsg]
evalMsgs = []
                }

  where
    optionExists :: String -> Bool
optionExists = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe KernelOpt
findOption
    findOption :: String -> Maybe KernelOpt
findOption String
opt =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
opt forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelOpt -> [String]
getOptionName) [KernelOpt]
kernelOpts

evalCommand Publisher
_ (Directive DirectiveType
GetType String
expr) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Type: " forall a. [a] -> [a] -> [a]
++ String
expr
  String -> Display
formatType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String
expr forall a. [a] -> [a] -> [a]
++ String
" :: ") forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => String -> m String
getType String
expr

evalCommand Publisher
_ (Directive DirectiveType
GetKind String
expr) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Kind: " forall a. [a] -> [a] -> [a]
++ String
expr
  (Kind
_, Kind
kind) <- forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
GHC.typeKind Bool
False String
expr
  DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let typeStr :: String
typeStr = DynFlags -> SDoc -> String
showSDocUnqual DynFlags
flags forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Kind
kind
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
formatType forall a b. (a -> b) -> a -> b
$ String
expr forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ String
typeStr

evalCommand Publisher
_ (Directive DirectiveType
GetKindBang String
expr) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Kind!: " forall a. [a] -> [a] -> [a]
++ String
expr
  (Kind
typ, Kind
kind) <- forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
GHC.typeKind Bool
True String
expr
  DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let kindStr :: SDoc
kindStr = String -> SDoc
text String
expr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
kind
  let typeStr :: SDoc
typeStr = SDoc
equals SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
typ
  let finalStr :: String
finalStr = DynFlags -> SDoc -> String
showSDocUnqual DynFlags
flags forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc
kindStr, SDoc
typeStr]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
formatType String
finalStr

evalCommand Publisher
_ (Directive DirectiveType
LoadFile String
names) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Load: " forall a. [a] -> [a] -> [a]
++ String
names

  [Display]
displays <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (String -> [String]
words String
names) forall a b. (a -> b) -> a -> b
$ \String
name -> do
                let filename :: String
filename = if String
".hs" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
name
                                 then String
name
                                 else String
name forall a. [a] -> [a] -> [a]
++ String
".hs"
                String
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
filename
                String
modName <- forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => String -> m [String]
getModuleName String
contents
                String -> String -> Interpreter Display
doLoadModule String
filename String
modName
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Display] -> Display
ManyDisplay [Display]
displays)

evalCommand Publisher
_ (Directive DirectiveType
Reload String
_) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state Interpreter Display
doReload

evalCommand Publisher
publish (Directive DirectiveType
ShellCmd String
cmd) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$
  -- Assume the first character of 'cmd' is '!'.
  case String -> [String]
words forall a b. (a -> b) -> a -> b
$ forall a. LineNumber -> [a] -> [a]
drop LineNumber
1 String
cmd of
    String
"cd":[String]
dirs -> do
      -- Get home so we can replace '~` with it.
      Either SomeException String
homeEither <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"HOME" :: IO (Either SomeException String))
      let home :: String
home =
            case Either SomeException String
homeEither of
              Left SomeException
_  -> String
"~"
              Right String
v -> String
v

      let directory :: String
directory = String -> String -> String -> String
replace String
"~" String
home forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
dirs
      Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
directory
      if Bool
exists
        then do
          -- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for
          -- user code, though.
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
directory

          -- Set the directory for user code.
          let cmd1 :: String
cmd1 = forall r. PrintfType r => String -> r
printf String
"IHaskellDirectory.setCurrentDirectory \"%s\"" forall a b. (a -> b) -> a -> b
$
                String -> String -> String -> String
replace String
" " String
"\\ " forall a b. (a -> b) -> a -> b
$
                  String -> String -> String -> String
replace String
"\"" String
"\\\"" String
directory
          ExecResult
_ <- forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
cmd1 ExecOptions
execOptions
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"No such directory: '%s'" String
directory
    [String]
cmd1 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      (Handle
pipe, Handle
hdl) <- IO (Handle, Handle)
createPipe
      let initProcSpec :: CreateProcess
initProcSpec = String -> CreateProcess
shell forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
cmd1
          procSpec :: CreateProcess
procSpec = CreateProcess
initProcSpec
            { std_in :: StdStream
std_in = StdStream
Inherit
            , std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hdl
            , std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
hdl
            }
      (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
process) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
procSpec

      -- Accumulate output from the process.
      MVar String
outputAccum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar String
""

      -- Start a loop to publish intermediate results.
      let
          -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
          -- argument of microseconds.
          ms :: LineNumber
ms = LineNumber
1000
          delay :: LineNumber
delay = LineNumber
100 forall a. Num a => a -> a -> a
* LineNumber
ms

          -- Maximum size of the output (after which we truncate).
          maxSize :: LineNumber
maxSize = LineNumber
100 forall a. Num a => a -> a -> a
* LineNumber
1000
          incSize :: LineNumber
incSize = LineNumber
200
          output :: String -> ErrorOccurred -> IO ()
output String
str = Publisher
publish forall a b. (a -> b) -> a -> b
$ Display -> EvaluationResult
IntermediateResult forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain String
str]

          loop :: IO Display
loop = do
            -- Wait and then check if the computation is done.
            LineNumber -> IO ()
threadDelay LineNumber
delay

            -- Read next chunk and append to accumulator.
            String
nextChunk <- Handle -> String -> LineNumber -> IO String
readChars Handle
pipe String
"\n" LineNumber
incSize
            forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
nextChunk))

            -- Check if we're done.
            Maybe ExitCode
mExitCode <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
process
            case Maybe ExitCode
mExitCode of
              Maybe ExitCode
Nothing -> do
                -- Write to frontend and repeat.
                forall a. MVar a -> IO a
readMVar MVar String
outputAccum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ErrorOccurred -> IO ()
output ErrorOccurred
Success
                IO Display
loop
              Just ExitCode
exitCode -> do
                String
next <- Handle -> String -> LineNumber -> IO String
readChars Handle
pipe String
"" LineNumber
maxSize
                forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
next))
                String
out <- forall a. MVar a -> IO a
readMVar MVar String
outputAccum
                case ExitCode
exitCode of
                  ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain String
out]
                  ExitFailure LineNumber
code -> do
                    let errMsg :: String
errMsg = String
"Process exited with error code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNumber
code
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ String
out forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
errMsg]

      IO Display
loop
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand Publisher
_ (Directive DirectiveType
GetHelp String
_) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Help via :help or :?."
  forall (m :: * -> *) a. Monad m => a -> m a
return
    EvalOut
      { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
      , evalResult :: Display
evalResult = [DisplayData] -> Display
Display [DisplayData
out]
      , evalState :: KernelState
evalState = KernelState
state
      , evalPager :: [DisplayData]
evalPager = []
      , evalMsgs :: [WidgetMsg]
evalMsgs = []
      }

  where
    out :: DisplayData
out = String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
                    [ String
"The following commands are available:"
                    , String
"    :extension <Extension>    -  Enable a GHC extension."
                    , String
"    :extension No<Extension>  -  Disable a GHC extension."
                    , String
"    :type <expression>        -  Print expression type."
                    , String
"    :info <name>              -  Print all info for a name."
                    , String
"    :hoogle <query>           -  Search for a query on Hoogle."
                    , String
"    :doc <ident>              -  Get documentation for an identifier via Hoogle."
                    , String
"    :set -XFlag -Wall         -  Set an option (like ghci)."
                    , String
"    :option <opt>             -  Set an option."
                    , String
"    :option no-<opt>          -  Unset an option."
                    , String
"    :?, :help                 -  Show this help text."
                    , String
"    :sprint <value>           -  Print a value without forcing evaluation."
                    , String
""
                    , String
"Any prefix of the commands will also suffice, e.g. use :ty for :type."
                    , String
""
                    , String
"Options:"
                    , String
"  lint        – enable or disable linting."
                    , String
"  svg         – use svg output (cannot be resized)."
                    , String
"  show-types  – show types of all bound names"
                    , String
"  show-errors – display Show instance missing errors normally."
                    , String
"  pager       – use the pager to display results of :info, :doc, :hoogle, etc."
                    ]

-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand Publisher
_ (Directive DirectiveType
GetInfo String
str) KernelState
state = KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Info: " forall a. [a] -> [a] -> [a]
++ String
str
  -- Get all the info for all the names we're given.
  String
strings <- [String] -> String
unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => String -> m [String]
getDescription String
str

  forall (m :: * -> *) a. Monad m => a -> m a
return
    EvalOut
      { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
      , evalResult :: Display
evalResult = [DisplayData] -> Display
Display [
          String -> DisplayData
plain String
strings
#if MIN_VERSION_ghc(8,4,0)
          , Maybe Text -> Text -> String -> DisplayData
htmlify (String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KernelState -> Maybe String
htmlCodeWrapperClass KernelState
state)
                    (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ KernelState -> String
htmlCodeTokenPrefix KernelState
state)
                    String
strings
#endif
          ]
      , evalState :: KernelState
evalState = KernelState
state
      , evalPager :: [DisplayData]
evalPager = []
      , evalMsgs :: [WidgetMsg]
evalMsgs = []
      }

evalCommand Publisher
_ (Directive DirectiveType
SearchHoogle String
query) KernelState
state = KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state forall a b. (a -> b) -> a -> b
$ do
  [HoogleResult]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [HoogleResult]
Hoogle.search String
query
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KernelState -> [HoogleResult] -> EvalOut
hoogleResults KernelState
state [HoogleResult]
results

evalCommand Publisher
_ (Directive DirectiveType
GetDoc String
query) KernelState
state = KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely KernelState
state forall a b. (a -> b) -> a -> b
$ do
  [HoogleResult]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [HoogleResult]
Hoogle.document String
query
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KernelState -> [HoogleResult] -> EvalOut
hoogleResults KernelState
state [HoogleResult]
results

evalCommand Publisher
_ (Directive DirectiveType
SPrint String
binding) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  IORef [String]
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
#if MIN_VERSION_ghc(9,4,0)
  let action = \_lflags _msgclass _srcspan msg -> modifyIORef' contents (showSDoc flags msg :)
#elif MIN_VERSION_ghc(9,0,0)
  let action :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
action = \DynFlags
_dflags WarnReason
_warn Severity
_sev SrcSpan
_srcspan SDoc
msg -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [String]
contents (DynFlags -> SDoc -> String
showSDoc DynFlags
flags SDoc
msg forall a. a -> [a] -> [a]
:)
#else
  let action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' contents (showSDoc flags msg :)
#endif
#if MIN_VERSION_ghc(9,2,0)
  forall (m :: * -> *).
GhcMonad m =>
((DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ())
 -> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM (forall a b. a -> b -> a
const DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
action)
#else
  let flags' = flags { log_action = action }
  _ <- setSessionDynFlags flags'
#endif
  forall (m :: * -> *). GhcMonad m => Bool -> Bool -> String -> m ()
Debugger.pprintClosureCommand Bool
False Bool
False String
binding
#if MIN_VERSION_ghc(9,2,0)
  forall (m :: * -> *). GhcMonad m => m ()
popLogHookM
#endif
  ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags
  [String]
sprint <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef [String]
contents
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
formatType ([String] -> String
unlines [String]
sprint)

evalCommand Publisher
output (Statement String
stmt) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ forall a.
Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO Publisher
output KernelState
state
                                                                    (forall a. String -> Captured a
CapturedStmt String
stmt)

evalCommand Publisher
output (Expression String
expr) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Expression:\n" forall a. [a] -> [a] -> [a]
++ String
expr

  -- Try to use `display` to convert our type into the output Dislay If typechecking fails and there
  -- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return
  -- False, and we just resort to plaintext.
  let displayExpr :: String
displayExpr = forall r. PrintfType r => String -> r
printf String
"(IHaskell.Display.display (%s))" String
expr :: String
#if MIN_VERSION_ghc(8,2,0)
  Bool
canRunDisplay <- forall a. Interpreter a -> Interpreter Bool
attempt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
displayExpr
#else
  canRunDisplay <- attempt $ exprType displayExpr
#endif

  -- Check if this is a widget.
  let widgetExpr :: String
widgetExpr = forall r. PrintfType r => String -> r
printf String
"(IHaskell.Display.Widget (%s))" String
expr :: String
#if MIN_VERSION_ghc(8,2,0)
  Bool
isWidget <- forall a. Interpreter a -> Interpreter Bool
attempt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
widgetExpr
#else
  isWidget <- attempt $ exprType widgetExpr
#endif

  -- Check if this is a template haskell declaration
  let declExpr :: String
declExpr = forall r. PrintfType r => String -> r
printf String
"((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" String
expr :: String
  let anyExpr :: String
anyExpr = forall r. PrintfType r => String -> r
printf String
"((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" String
expr :: String
#if MIN_VERSION_ghc(8,2,0)
  Bool
isTHDeclaration <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (forall a. Interpreter a -> Interpreter Bool
attempt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
declExpr) (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Interpreter a -> Interpreter Bool
attempt (forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
anyExpr))
#else
  isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr))
#endif

  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Can Display: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
canRunDisplay
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Is Widget: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
isWidget
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Is Declaration: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
isTHDeclaration

  if Bool
isTHDeclaration
    then
    -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the
    -- declaration made.
    do
      ()
_ <- forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Suppressing display for template haskell declaration"
      [Name]
_ <- forall (m :: * -> *). GhcMonad m => String -> m [Name]
GHC.runDecls String
expr
      forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
          , evalResult :: Display
evalResult = forall a. Monoid a => a
mempty
          , evalState :: KernelState
evalState = KernelState
state
          , evalPager :: [DisplayData]
evalPager = []
          , evalMsgs :: [WidgetMsg]
evalMsgs = []
          }
    else if Bool
canRunDisplay
           then
           -- Use the display. As a result, `it` is set to the output.
           String -> Interpreter EvalOut
useDisplay String
displayExpr
           else do
             -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
             -- then use it.
             EvalOut
evalOut <- Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output (String -> CodeBlock
Statement String
expr) KernelState
state

             let out :: Display
out = EvalOut -> Display
evalResult EvalOut
evalOut
                 showErr :: Bool
showErr = Display -> Bool
isShowError Display
out

             -- If evaluation failed, return the failure. If it was successful, we may be able to use the
             -- IHaskellDisplay typeclass.
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
showErr Bool -> Bool -> Bool
|| KernelState -> Bool
useShowErrors KernelState
state
                        then EvalOut
evalOut
                        else EvalOut -> EvalOut
postprocessShowError EvalOut
evalOut

  where
    -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The
    -- result of the action is discarded.
    attempt :: Interpreter a -> Interpreter Bool
    attempt :: forall a. Interpreter a -> Interpreter Bool
attempt Interpreter a
action = forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (Interpreter a
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) SomeException -> Interpreter Bool
failure
      where
        failure :: SomeException -> Interpreter Bool
        failure :: SomeException -> Interpreter Bool
failure SomeException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    -- Check if the error is due to trying to print something that doesn't implement the Show typeclass.
    isShowError :: Display -> Bool
isShowError (ManyDisplay [Display]
_) = Bool
False
    isShowError (Display [DisplayData]
errs) =
      -- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as
      -- GHC.Show.Show. This is also very fragile!
      String
"No instance for (Show" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
msg Bool -> Bool -> Bool
&&
      forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"print it" String
msg
      where
        msg :: String
msg = [DisplayData] -> String
extractPlain [DisplayData]
errs

    isSvg :: DisplayData -> Bool
isSvg (DisplayData MimeType
mime Text
_) = MimeType
mime forall a. Eq a => a -> a -> Bool
== MimeType
MimeSvg

    removeSvg :: Display -> Display
    removeSvg :: Display -> Display
removeSvg (Display [DisplayData]
disps) = [DisplayData] -> Display
Display forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayData -> Bool
isSvg) [DisplayData]
disps
    removeSvg (ManyDisplay [Display]
disps) = [Display] -> Display
ManyDisplay forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Display -> Display
removeSvg [Display]
disps

    useDisplay :: String -> Interpreter EvalOut
useDisplay String
_displayExpr = do
      -- If there are instance matches, convert the object into a Display. We also serialize it into a
      -- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring,
      -- which we promptly unserialize. Note that attempting to do this without the serialization to
      -- binary and back gives very strange errors - all the types match but it refuses to decode back
      -- into a Display. Suppress output, so as not to mess up console. First, evaluate the expression in
      -- such a way that we have access to `it`.
      Bool
io <- forall {t}. PrintfArg t => t -> Interpreter Bool
isIO String
expr
      let stmtTemplate :: String
stmtTemplate = if Bool
io
                           then String
"it <- (%s)"
                           else String
"let { it = %s }"
      EvalOut
evalOut <- Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output (String -> CodeBlock
Statement forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
stmtTemplate String
expr) KernelState
state
      case EvalOut -> ErrorOccurred
evalStatus EvalOut
evalOut of
        ErrorOccurred
Failure -> forall (m :: * -> *) a. Monad m => a -> m a
return EvalOut
evalOut
        ErrorOccurred
Success -> KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
          -- Compile the display data into a bytestring.
          let cexpr :: String
cexpr = String
"fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"
          Dynamic
displayedBytestring <- forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
cexpr

          -- Convert from the bytestring into a display.
          case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
displayedBytestring of
            Maybe (IO ByteString)
Nothing -> forall a. HasCallStack => String -> a
error String
"Expecting lazy Bytestring"
            Just IO ByteString
bytestringIO -> do
              ByteString
bytestring <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
bytestringIO
              case forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Binary.decodeOrFail ByteString
bytestring of
                Left (ByteString
_, ByteOffset
_, String
err) -> forall a. HasCallStack => String -> a
error String
err
                Right (ByteString
_, ByteOffset
_, Display
disp) ->
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                    if KernelState -> Bool
useSvg KernelState
state
                      then Display
disp :: Display
                      else Display -> Display
removeSvg Display
disp

#if MIN_VERSION_ghc(8,2,0)
    isIO :: t -> Interpreter Bool
isIO t
exp = forall a. Interpreter a -> Interpreter Bool
attempt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"((\\x -> x) :: IO a -> IO a) (%s)" t
exp
#else
    isIO exp = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp
#endif

    postprocessShowError :: EvalOut -> EvalOut
    postprocessShowError :: EvalOut -> EvalOut
postprocessShowError EvalOut
evalOut = EvalOut
evalOut { evalResult :: Display
evalResult = [DisplayData] -> Display
Display forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DisplayData -> DisplayData
postprocess [DisplayData]
disps }
      where
        Display [DisplayData]
disps = EvalOut -> Display
evalResult EvalOut
evalOut
        txt :: String
txt = [DisplayData] -> String
extractPlain [DisplayData]
disps

        postprocess :: DisplayData -> DisplayData
postprocess (DisplayData MimeType
MimeHtml Text
_) =
          Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
fmt String
unshowableType (String -> String -> String
formatErrorWithClass String
"err-msg collapse" String
txt) String
script
          where
            fmt :: String
fmt = String
"<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
            script :: String
script = [String] -> String
unlines
                       [ String
"$('#unshowable').on('click', function(e) {"
                       , String
"    e.preventDefault();"
                       , String
"    var $this = $(this);"
                       , String
"    var $collapse = $this.closest('.collapse-group').find('.err-msg');"
                       , String
"    $collapse.collapse('toggle');"
                       , String
"});"
                       ]

        postprocess DisplayData
other = DisplayData
other

        unshowableType :: String
unshowableType = forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ do
          let pieces :: [String]
pieces = String -> [String]
words String
txt
              before :: [String]
before = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= String
"arising") [String]
pieces
              after :: String
after = forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= String
"(Show") [String]
before

          Char
firstChar <- forall a. [a] -> Maybe a
headMay String
after
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Char
firstChar forall a. Eq a => a -> a -> Bool
== Char
'('
                     then forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail String
after
                     else String
after


evalCommand Publisher
_ (Declaration String
decl) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Declaration:\n" forall a. [a] -> [a] -> [a]
++ String
decl
  [String]
boundNames <- forall (m :: * -> *). GhcMonad m => String -> m [String]
evalDeclarations String
decl
  let nonDataNames :: [String]
nonDataNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) [String]
boundNames

  -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
  if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ KernelState -> Bool
useShowTypes KernelState
state
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    else do
      -- Get all the type strings.
      DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      [String]
types <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
nonDataNames forall a b. (a -> b) -> a -> b
$ \String
name -> do
#if MIN_VERSION_ghc(8,2,0)
                 String
theType <- DynFlags -> SDoc -> String
showSDocUnqual DynFlags
dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
name
#else
                 theType <- showSDocUnqual dflags . ppr <$> exprType name
#endif
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ String
theType

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
formatGetType [String]
types]

evalCommand Publisher
_ (TypeSignature String
sig) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$
  -- We purposefully treat this as a "success" because that way execution continues. Empty type
  -- signatures are likely due to a parse error later on, and we want that to be displayed.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"The type signature " forall a. [a] -> [a] -> [a]
++ String
sig forall a. [a] -> [a] -> [a]
++ String
"\nlacks an accompanying binding."

evalCommand Publisher
_ (ParseError StringLoc
loc String
err) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Parse Error."
  forall (m :: * -> *) a. Monad m => a -> m a
return
    EvalOut
      { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
      , evalResult :: Display
evalResult = String -> Display
displayError forall a b. (a -> b) -> a -> b
$ StringLoc -> String -> String
formatParseError StringLoc
loc String
err
      , evalState :: KernelState
evalState = KernelState
state
      , evalPager :: [DisplayData]
evalPager = []
      , evalMsgs :: [WidgetMsg]
evalMsgs = []
      }

evalCommand Publisher
_ (Pragma (PragmaUnsupported String
pragmaType) [String]
_pragmas) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"Pragmas of type " forall a. [a] -> [a] -> [a]
++ String
pragmaType forall a. [a] -> [a] -> [a]
++ String
"\nare not supported."

evalCommand Publisher
output (Pragma PragmaType
PragmaLanguage [String]
pragmas) KernelState
state = do
  forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Got LANGUAGE pragma " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
pragmas
  Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output (DirectiveType -> String -> CodeBlock
Directive DirectiveType
SetExtension forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
pragmas) KernelState
state

hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
hoogleResults :: KernelState -> [HoogleResult] -> EvalOut
hoogleResults KernelState
state [HoogleResult]
results =
  EvalOut
    { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
    , evalResult :: Display
evalResult = forall a. Monoid a => a
mempty
    , evalState :: KernelState
evalState = KernelState
state
    , evalPager :: [DisplayData]
evalPager = [ String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (OutputFormat -> HoogleResult -> String
Hoogle.render OutputFormat
Hoogle.Plain) [HoogleResult]
results
                  , Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (OutputFormat -> HoogleResult -> String
Hoogle.render OutputFormat
Hoogle.HTML) [HoogleResult]
results
                  ]
    , evalMsgs :: [WidgetMsg]
evalMsgs = []
    }

doLoadModule :: String -> String -> Ghc Display
doLoadModule :: String -> String -> Interpreter Display
doLoadModule String
name String
modName = do
  -- Remember which modules we've loaded before.
  [InteractiveImport]
importedModules <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch ([InteractiveImport] -> SomeException -> Interpreter Display
unload [InteractiveImport]
importedModules) forall a b. (a -> b) -> a -> b
$ do
    -- Compile loaded modules.
    DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    IORef [String]
errRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
#if MIN_VERSION_ghc(9,4,0)
    let logAction = \_lflags _msgclass _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :)
#elif MIN_VERSION_ghc(9,0,0)
    let logAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logAction = \DynFlags
_dflags WarnReason
_warn Severity
_sev SrcSpan
_srcspan SDoc
msg -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [String]
errRef (DynFlags -> SDoc -> String
showSDoc DynFlags
flags SDoc
msg forall a. a -> [a] -> [a]
:)
#else
    let logAction = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :)
#endif
#if MIN_VERSION_ghc(9,2,0)
    forall (m :: * -> *).
GhcMonad m =>
((DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ())
 -> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM (forall a b. a -> b -> a
const DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logAction)
#endif
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set GeneralFlag
Opt_BuildDynamicToo
      DynFlags
flags
#if MIN_VERSION_ghc(9,2,0)
        { backend :: Backend
backend = DynFlags -> Backend
objTarget DynFlags
flags
#else
        { hscTarget = objTarget flags
        , log_action = logAction
#endif
        }

    -- Load the new target.
#if MIN_VERSION_ghc(9,4,0)
    target <- guessTarget name Nothing Nothing
#else
    Target
target <- forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
name forall a. Maybe a
Nothing
#endif
    [Target]
oldTargets <- forall (m :: * -> *). GhcMonad m => m [Target]
getTargets
    -- Add a target, but make sure targets are unique!
    forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
    forall (m :: * -> *). GhcMonad m => m [Target]
getTargets forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Target -> TargetId
targetId) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets
    SuccessFlag
result <- forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets

    -- Reset the context, since loading things screws it up.
    Ghc ()
initializeItVariable

    -- Reset targets if we failed.
    case SuccessFlag
result of
      SuccessFlag
Failed      -> forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
oldTargets
      Succeeded{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Add imports
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext forall a b. (a -> b) -> a -> b
$
      case SuccessFlag
result of
        SuccessFlag
Failed    -> [InteractiveImport]
importedModules
        SuccessFlag
Succeeded -> ImportDecl GhcPs -> InteractiveImport
IIDecl (ModuleName -> ImportDecl GhcPs
simpleImportDecl forall a b. (a -> b) -> a -> b
$ String -> ModuleName
mkModuleName String
modName) forall a. a -> [a] -> [a]
: [InteractiveImport]
importedModules

    -- Switch back to interpreted mode.
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags
#if MIN_VERSION_ghc(9,2,0)
    forall (m :: * -> *). GhcMonad m => m ()
popLogHookM
#endif

    case SuccessFlag
result of
      SuccessFlag
Succeeded -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      SuccessFlag
Failed -> do
        String
errorStrs <- [String] -> String
unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef [String]
errRef)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"Failed to load module " forall a. [a] -> [a] -> [a]
++ String
modName forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
errorStrs

  where
    unload :: [InteractiveImport] -> SomeException -> Ghc Display
    unload :: [InteractiveImport] -> SomeException -> Interpreter Display
unload [InteractiveImport]
imported SomeException
exception = do
      forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
print forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
exception
      -- Explicitly clear targets
      forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets []
      SuccessFlag
_ <- forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets

      -- Switch to interpreted mode!
      DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,6,0)
      _ <- setSessionDynFlags flags { backend = interpreterBackend }
#elif MIN_VERSION_ghc(9,2,0)
      ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags { backend :: Backend
backend = Backend
Interpreter }
#else
      _ <- setSessionDynFlags flags { hscTarget = HscInterpreted }
#endif

      -- Return to old context, make sure we have `it`.
      forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
imported
      Ghc ()
initializeItVariable

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"Failed to load module " forall a. [a] -> [a] -> [a]
++ String
modName forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
exception

doReload :: Ghc Display
doReload :: Interpreter Display
doReload = do
  -- Remember which modules we've loaded before.
  [InteractiveImport]
importedModules <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch ([InteractiveImport] -> SomeException -> Interpreter Display
unload [InteractiveImport]
importedModules) forall a b. (a -> b) -> a -> b
$ do
    -- Compile loaded modules.
    DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    IORef [String]
errRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set GeneralFlag
Opt_BuildDynamicToo
      DynFlags
flags
#if MIN_VERSION_ghc(9,2,0)
        { backend :: Backend
backend = DynFlags -> Backend
objTarget DynFlags
flags
#elif MIN_VERSION_ghc(9,0,0)
        { hscTarget = objTarget flags
        , log_action = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :)
#else
        { hscTarget = objTarget flags
        , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :)
#endif
        }

    -- Store the old targets in case of failure.
    [Target]
oldTargets <- forall (m :: * -> *). GhcMonad m => m [Target]
getTargets
    SuccessFlag
result <- forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets

    -- Reset the context, since loading things screws it up.
    Ghc ()
initializeItVariable

    -- Reset targets if we failed.
    case SuccessFlag
result of
      SuccessFlag
Failed      -> forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
oldTargets
      Succeeded{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Add imports
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
importedModules

    -- Switch back to interpreted mode.
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags

    case SuccessFlag
result of
      SuccessFlag
Succeeded -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      SuccessFlag
Failed -> do
        String
errorStrs <- [String] -> String
unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef [String]
errRef)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"Failed to reload.\n" forall a. [a] -> [a] -> [a]
++ String
errorStrs

  where
    unload :: [InteractiveImport] -> SomeException -> Ghc Display
    unload :: [InteractiveImport] -> SomeException -> Interpreter Display
unload [InteractiveImport]
imported SomeException
exception = do
      forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
print forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
exception
      -- Explicitly clear targets
      forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets []
      SuccessFlag
_ <- forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets

      -- Switch to interpreted mode!
      DynFlags
flags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if MIN_VERSION_ghc(9,6,0)
      _ <- setSessionDynFlags flags { backend = interpreterBackend }
#elif MIN_VERSION_ghc(9,2,0)
      ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
flags { backend :: Backend
backend = Backend
Interpreter }
#else
      _ <- setSessionDynFlags flags { hscTarget = HscInterpreted }
#endif

      -- Return to old context, make sure we have `it`.
      forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
imported
      Ghc ()
initializeItVariable

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Display
displayError forall a b. (a -> b) -> a -> b
$ String
"Failed to reload."

#if MIN_VERSION_ghc(9,2,0)
objTarget :: DynFlags -> Backend
objTarget :: DynFlags -> Backend
objTarget = Platform -> Backend
platformDefaultBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Platform
targetPlatform
#elif MIN_VERSION_ghc(8,10,0)
objTarget :: DynFlags -> HscTarget
objTarget = defaultObjectTarget
#else
objTarget :: DynFlags -> HscTarget
objTarget flags = defaultObjectTarget $ targetPlatform flags
#endif

data Captured a = CapturedStmt String
                | CapturedIO (IO a)

capturedEval :: (String -> IO ()) -- ^ Function used to publish intermediate output.
             -> Captured a -- ^ Statement to evaluate.
             -> Interpreter (String, ExecResult) -- ^ Return the output and result.
capturedEval :: forall a.
(String -> IO ()) -> Captured a -> Interpreter (String, ExecResult)
capturedEval String -> IO ()
output Captured a
stmt = do
  -- Generate random variable names to use so that we cannot accidentally override the variables by
  -- using the right names in the terminal.
  StdGen
gen <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
  let
      -- Variable names generation.
      rand :: String
rand = forall a. LineNumber -> [a] -> [a]
take LineNumber
20 forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
randomRs (Char
'0', Char
'9') StdGen
gen
      var :: String -> String
var String
name = String
name forall a. [a] -> [a] -> [a]
++ String
rand

      -- Variables for the pipe input and outputs.
      readVariable :: String
readVariable = String -> String
var String
"file_read_var_"
      writeVariable :: String
writeVariable = String -> String
var String
"file_write_var_"

      -- Variable where to store old stdout.
      oldVariableStdout :: String
oldVariableStdout = String -> String
var String
"old_var_stdout_"

      -- Variable where to store old stderr.
      oldVariableStderr :: String
oldVariableStderr = String -> String
var String
"old_var_stderr_"

      -- Variable used to store true `it` value.
      itVariable :: String
itVariable = String -> String
var String
"it_var_"

      voidpf :: String -> r
voidpf String
str = forall r. PrintfType r => String -> r
printf forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> [a] -> [a]
++ String
" IHaskellPrelude.>> IHaskellPrelude.return ()"

      -- Statements run before the thing we're evaluating.
      initStmts :: [String]
initStmts =
        [ forall r. PrintfType r => String -> r
printf String
"let %s = it" String
itVariable
        , forall r. PrintfType r => String -> r
printf String
"(%s, %s) <- IHaskellIO.createPipe" String
readVariable String
writeVariable
        , forall r. PrintfType r => String -> r
printf String
"%s <- IHaskellIO.dup IHaskellIO.stdOutput" String
oldVariableStdout
        , forall r. PrintfType r => String -> r
printf String
"%s <- IHaskellIO.dup IHaskellIO.stdError" String
oldVariableStderr
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellIO.dupTo %s IHaskellIO.stdOutput" String
writeVariable
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellIO.dupTo %s IHaskellIO.stdError" String
writeVariable
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellSysIO.hSetBuffering IHaskellSysIO.stderr IHaskellSysIO.NoBuffering"
        , forall r. PrintfType r => String -> r
printf String
"let it = %s" String
itVariable
        ]

      -- Statements run after evaluation.
      postStmts :: [String]
postStmts =
        [ forall r. PrintfType r => String -> r
printf String
"let %s = it" String
itVariable
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellSysIO.hFlush IHaskellSysIO.stdout"
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellSysIO.hFlush IHaskellSysIO.stderr"
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellIO.dupTo %s IHaskellIO.stdOutput" String
oldVariableStdout
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellIO.dupTo %s IHaskellIO.stdError" String
oldVariableStderr
        , forall r. PrintfType r => String -> r
voidpf String
"IHaskellIO.closeFd %s" String
writeVariable
        , forall r. PrintfType r => String -> r
printf String
"let it = %s" String
itVariable
        ]

      goStmt :: String -> Ghc ExecResult
      goStmt :: String -> Ghc ExecResult
goStmt String
s = forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
s ExecOptions
execOptions

      runWithResult :: Captured a -> Ghc ExecResult
runWithResult (CapturedStmt String
str) = String -> Ghc ExecResult
goStmt String
str
      runWithResult (CapturedIO IO a
io) = do
        AnyException
stat <- forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return AnyException
NoException) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> AnyException
AnyException)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
          case AnyException
stat of
            AnyException
NoException    -> Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. b -> Either a b
Right []) Word64
0
            AnyException SomeException
e -> Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (forall a b. a -> Either a b
Left SomeException
e)   Word64
0

  -- Initialize evaluation context.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
initStmts String -> Ghc ExecResult
goStmt

  -- This works fine on GHC 8.0 and newer
  Dynamic
dyn <- forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
readVariable
  Handle
pipe <- case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
            Maybe Fd
Nothing -> forall a. HasCallStack => String -> a
error String
"Evaluate: Bad pipe"
            Just Fd
fd -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Handle
hdl <- Fd -> IO Handle
fdToHandle Fd
fd
                Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hdl TextEncoding
utf8
                forall (m :: * -> *) a. Monad m => a -> m a
return Handle
hdl

  -- Keep track of whether execution has completed.
  MVar Bool
completed <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Bool
False
  MVar Bool
finishedReading <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
  MVar String
outputAccum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar String
""

  -- Start a loop to publish intermediate results.
  let
      -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
      -- argument of microseconds.
      ms :: LineNumber
ms = LineNumber
1000
      delay :: LineNumber
delay = LineNumber
100 forall a. Num a => a -> a -> a
* LineNumber
ms

      -- Maximum size of the output (after which we truncate).
      maxSize :: LineNumber
maxSize = LineNumber
100 forall a. Num a => a -> a -> a
* LineNumber
1000

      loop :: IO ()
loop = do
        -- Wait and then check if the computation is done.
        LineNumber -> IO ()
threadDelay LineNumber
delay
        Bool
computationDone <- forall a. MVar a -> IO a
readMVar MVar Bool
completed

        if Bool -> Bool
not Bool
computationDone
          then do
            -- Read next chunk and append to accumulator.
            String
nextChunk <- Handle -> String -> LineNumber -> IO String
readChars Handle
pipe String
"\n" LineNumber
100
            forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
nextChunk))

            -- Write to frontend and repeat.
            forall a. MVar a -> IO a
readMVar MVar String
outputAccum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
output
            IO ()
loop
          else do
            -- Read remainder of output and accumulate it.
            String
nextChunk <- Handle -> String -> LineNumber -> IO String
readChars Handle
pipe String
"" LineNumber
maxSize
            forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
nextChunk))

            -- We're done reading.
            forall a. MVar a -> a -> IO ()
putMVar MVar Bool
finishedReading Bool
True

  ThreadId
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
loop

  ExecResult
result <- forall a b. Ghc a -> Ghc b -> Ghc a
gfinally (forall {a}. Captured a -> Ghc ExecResult
runWithResult Captured a
stmt) forall a b. (a -> b) -> a -> b
$ do
              -- Execution is done.
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
completed (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

              -- Finalize evaluation context.
              forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
postStmts String -> Ghc ExecResult
goStmt

              -- Once context is finalized, reading can finish. Wait for reading to finish to that the output
              -- accumulator is completely filled.
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar Bool
finishedReading

  String
printedOutput <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar String
outputAccum
  forall (m :: * -> *) a. Monad m => a -> m a
return (String
printedOutput, ExecResult
result)

data AnyException = NoException
                  | AnyException SomeException

capturedIO :: Publisher -> KernelState -> IO a -> Interpreter Display
capturedIO :: forall a. Publisher -> KernelState -> IO a -> Interpreter Display
capturedIO Publisher
publish KernelState
state IO a
action = do
  let showError :: SomeException -> Interpreter Display
showError = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Display
displayError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
      handler :: SomeException -> Interpreter Display
handler e :: SomeException
e@SomeException{} = SomeException -> Interpreter Display
showError SomeException
e
  forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (forall a.
Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO Publisher
publish KernelState
state (forall a. IO a -> Captured a
CapturedIO IO a
action)) SomeException -> Interpreter Display
handler

-- | Evaluate a @Captured@, and then publish the final result to the frontend. Returns the final
-- Display.
evalStatementOrIO :: Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO :: forall a.
Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO Publisher
publish KernelState
state Captured a
cmd = do
  let output :: String -> ErrorOccurred -> IO ()
output String
str = Publisher
publish forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> EvaluationResult
IntermediateResult forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain String
str]

  case Captured a
cmd of
    CapturedStmt String
stmt ->
      forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Statement:\n" forall a. [a] -> [a] -> [a]
++ String
stmt
    CapturedIO IO a
_ ->
      forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Evaluating Action"

  (String
printed, ExecResult
result) <- forall a.
(String -> IO ()) -> Captured a -> Interpreter (String, ExecResult)
capturedEval (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ErrorOccurred -> IO ()
output ErrorOccurred
Success) Captured a
cmd
  case ExecResult
result of
    ExecComplete (Right [Name]
names) Word64
_ -> do
      DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags

      let allNames :: [String]
allNames = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) [Name]
names
          isItName :: String -> Bool
isItName String
name =
            String
name forall a. Eq a => a -> a -> Bool
== String
"it" Bool -> Bool -> Bool
||
            String
name forall a. Eq a => a -> a -> Bool
== String
"it" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (KernelState -> LineNumber
getExecutionCounter KernelState
state)
          nonItNames :: [String]
nonItNames = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isItName) [String]
allNames
          oput :: [DisplayData]
oput = [ String -> DisplayData
plain String
printed
                   | Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ String -> String
strip String
printed ]

      forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state forall a b. (a -> b) -> a -> b
$ String
"Names: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
allNames

      -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
      if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ KernelState -> Bool
useShowTypes KernelState
state
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [DisplayData]
oput
        else do
          -- Get all the type strings.
          [String]
types <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
nonItNames forall a b. (a -> b) -> a -> b
$ \String
name -> do
#if MIN_VERSION_ghc(8,2,0)
                     String
theType <- DynFlags -> SDoc -> String
showSDocUnqual DynFlags
dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
name
#else
                     theType <- showSDocUnqual dflags . ppr <$> exprType name
#endif
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ String
theType

          let joined :: String
joined = [String] -> String
unlines [String]
types
              htmled :: String
htmled = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
formatGetType [String]
types

          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            case [DisplayData] -> String
extractPlain [DisplayData]
oput of
              String
"" -> [DisplayData] -> Display
Display [Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) String
htmled]

              -- Return plain and html versions. Previously there was only a plain version.
              String
txt -> [DisplayData] -> Display
Display [String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ String
joined forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
txt, Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ String
htmled forall a. [a] -> [a] -> [a]
++ String -> String
mono String
txt]

    ExecComplete (Left SomeException
exception) Word64
_ -> forall a. SomeException -> Ghc a
throw SomeException
exception
    ExecBreak{} -> forall a. HasCallStack => String -> a
error String
"Should not break."

-- Read from a file handle until we hit a delimiter or until we've read as many characters as
-- requested
readChars :: Handle -> String -> Int -> IO String
readChars :: Handle -> String -> LineNumber -> IO String
readChars Handle
_handle String
_delims LineNumber
0 =
  -- If we're done reading, return nothing.
  forall (m :: * -> *) a. Monad m => a -> m a
return []
readChars Handle
hdl String
delims LineNumber
nchars = do
  -- Try reading a single character. It will throw an exception if the handle is already closed.
  Either SomeException Char
tryRead <- forall a. IO a -> IO (Either SomeException a)
gtry forall a b. (a -> b) -> a -> b
$ Handle -> IO Char
hGetChar Handle
hdl :: IO (Either SomeException Char)
  case Either SomeException Char
tryRead of
    Right Char
ch ->
      -- If this is a delimiter, stop reading.
      if Char
ch forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
delims
        then forall (m :: * -> *) a. Monad m => a -> m a
return [Char
ch]
        else do
          String
next <- Handle -> String -> LineNumber -> IO String
readChars Handle
hdl String
delims (LineNumber
nchars forall a. Num a => a -> a -> a
- LineNumber
1)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char
ch forall a. a -> [a] -> [a]
: String
next
    -- An error occurs at the end of the stream, so just stop reading.
    Left SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []

formatError :: ErrMsg -> String
formatError :: String -> String
formatError = String -> String -> String
formatErrorWithClass String
"err-msg"

formatErrorWithClass :: String -> ErrMsg -> String
formatErrorWithClass :: String -> String -> String
formatErrorWithClass String
cls =
  forall r. PrintfType r => String -> r
printf String
"<span class='%s'>%s</span>" String
cls forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"\n" String
"<br/>" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String
fixDollarSigns forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"<" String
"&lt;" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
">" String
"&gt;" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"&" String
"&amp;" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
useDashV String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"Ghci" String
"IHaskell" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"‘interactive:" String
"‘" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String
rstrip forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String
typeCleaner
  where
    fixDollarSigns :: String -> String
fixDollarSigns = String -> String -> String -> String
replace String
"$" String
"<span>&dollar;</span>"
    useDashV :: String
useDashV = String
"\n    Use -v to see a list of the files searched for."

formatParseError :: StringLoc -> String -> ErrMsg
formatParseError :: StringLoc -> String -> String
formatParseError (Loc LineNumber
ln LineNumber
col) =
  forall r. PrintfType r => String -> r
printf String
"Parse error (line %d, column %d): %s" LineNumber
ln LineNumber
col

formatGetType :: String -> String
formatGetType :: String -> String
formatGetType = forall r. PrintfType r => String -> r
printf String
"<span class='get-type'>%s</span>"

formatType :: String -> Display
formatType :: String -> Display
formatType String
typeStr = [DisplayData] -> Display
Display [String -> DisplayData
plain String
typeStr, Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ String -> String
formatGetType String
typeStr]

displayError :: ErrMsg -> Display
displayError :: String -> Display
displayError String
msg = [DisplayData] -> Display
Display [String -> DisplayData
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
typeCleaner forall a b. (a -> b) -> a -> b
$ String
msg, Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) forall a b. (a -> b) -> a -> b
$ String -> String
formatError String
msg]

mono :: String -> String
mono :: String -> String
mono = forall r. PrintfType r => String -> r
printf String
"<span class='mono'>%s</span>"