{-# 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           Control.Monad.Trans.State (runStateT)
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

import qualified Data.Text as Text
import           IHaskell.Eval.Evaluate.HTML (htmlify)

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Data.FastString
#else
import           FastString (unpackFS)
#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 = Ghc a -> (SomeException -> Ghc a) -> Ghc a
forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, 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 = IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, 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 = Ghc a -> Ghc b -> Ghc a
forall (m :: * -> *) a b.
(HasCallStack, 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 = (e -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle

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


-- | Set GHC's verbosity for debugging
ghcVerbosity :: Maybe Int
ghcVerbosity :: Maybe LineNumber
ghcVerbosity = Maybe LineNumber
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 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String -> String
`replace` String
"") [String]
fullPrefixes)
  where
    fullPrefixes :: [String]
fullPrefixes = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
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 = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KernelState -> Bool
kernelDebug KernelState
state) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DEBUG: " String -> String -> String
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 = [String] -> Set String
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 = String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
forall a. String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
interpret String
GHC.Paths.libdir Bool
False Bool
False (Interpreter a -> Bool -> Interpreter a
forall a b. a -> b -> a
const Interpreter a
v)

-- | Evaluation function for testing.
testEvaluate :: String -> IO ()
testEvaluate :: String -> IO ()
testEvaluate String
str = IO (KernelState, ErrorOccurred) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (KernelState, ErrorOccurred) -> IO ())
-> IO (KernelState, ErrorOccurred) -> IO ()
forall a b. (a -> b) -> a -> b
$ Interpreter (KernelState, ErrorOccurred)
-> IO (KernelState, ErrorOccurred)
forall a. Interpreter a -> IO a
testInterpret (Interpreter (KernelState, ErrorOccurred)
 -> IO (KernelState, ErrorOccurred))
-> Interpreter (KernelState, ErrorOccurred)
-> IO (KernelState, ErrorOccurred)
forall a b. (a -> b) -> a -> b
$
  KernelState
-> String
-> Publisher
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter (KernelState, ErrorOccurred)
evaluate KernelState
defaultKernelState String
str (\EvaluationResult
_ ErrorOccurred
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\KernelState
state [WidgetMsg]
_ -> KernelState -> IO KernelState
forall a. a -> IO a
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 = Maybe String -> Interpreter a -> IO a
forall a. Maybe String -> Ghc a -> IO a
runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir) (Interpreter a -> IO a) -> Interpreter a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  -- If we're in a sandbox, add the relevant package database
  Maybe String
sandboxPackages <- IO (Maybe String) -> Ghc (Maybe String)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe String)
getSandboxPackageConf
  Maybe String -> Ghc ()
forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhci Maybe String
sandboxPackages
  case Maybe LineNumber
ghcVerbosity of
    Just LineNumber
verb -> do
      DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      Ghc () -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> Ghc ()) -> DynFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags { verbosity = verb }
    Maybe LineNumber
Nothing -> () -> Ghc ()
forall a. a -> Ghc a
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 <- IO String -> Ghc String
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getIHaskellDir
  let cmd :: String
cmd = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"IHaskell.IPython.Stdin.fixStdin \"%s\"" String
dir
  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
allowedStdin Bool -> Bool -> Bool
&& Bool
hasSupportLibraries) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Ghc ExecResult -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc ExecResult -> Ghc ()) -> Ghc ExecResult -> Ghc ()
forall a b. (a -> b) -> a -> b
$
    String -> ExecOptions -> Ghc ExecResult
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 -> DynFlags -> HscEnv -> GenUnitInfo UnitId -> IO String
packageIdString' Logger
logger DynFlags
dflags HscEnv
hsc_env GenUnitInfo UnitId
pkg_cfg = do
    ([UnitDatabase UnitId]
_, UnitState
unitState, HomeUnit
_, Maybe PlatformConstants
_) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
forall a. Maybe a
Nothing (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env)
    case (UnitState -> Unit -> Maybe (GenUnitInfo UnitId)
lookupUnit UnitState
unitState (Unit -> Maybe (GenUnitInfo UnitId))
-> Unit -> Maybe (GenUnitInfo UnitId)
forall a b. (a -> b) -> a -> b
$ GenUnitInfo UnitId -> Unit
mkUnit GenUnitInfo UnitId
pkg_cfg) of
      Maybe (GenUnitInfo UnitId)
Nothing -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"(unknown)"
      Just GenUnitInfo UnitId
cfg -> let
        PackageName FastString
name = GenUnitInfo UnitId -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName GenUnitInfo UnitId
cfg
        in String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
name
#elif MIN_VERSION_ghc(9,2,0)
packageIdString' :: Logger -> DynFlags -> UnitInfo -> IO String
packageIdString' logger dflags pkg_cfg = do
    (_, unitState, _, _) <- initUnits logger dflags Nothing
    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,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
#else
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
#endif

#if MIN_VERSION_ghc(9,4,0)
getPackageConfigs :: Logger -> DynFlags -> HscEnv -> IO [GenUnitInfo UnitId]
getPackageConfigs :: Logger -> DynFlags -> HscEnv -> IO [GenUnitInfo UnitId]
getPackageConfigs Logger
logger DynFlags
dflags HscEnv
hsc_env = do
    ([UnitDatabase UnitId]
pkgDb, UnitState
_, HomeUnit
_, Maybe PlatformConstants
_) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
forall a. Maybe a
Nothing (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env)
    [GenUnitInfo UnitId] -> IO [GenUnitInfo UnitId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenUnitInfo UnitId] -> IO [GenUnitInfo UnitId])
-> [GenUnitInfo UnitId] -> IO [GenUnitInfo UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitDatabase UnitId -> [GenUnitInfo UnitId])
-> [UnitDatabase UnitId] -> [GenUnitInfo UnitId]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap UnitDatabase UnitId -> [GenUnitInfo UnitId]
forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits [UnitDatabase UnitId]
pkgDb
#elif MIN_VERSION_ghc(9,2,0)
getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId]
getPackageConfigs logger dflags = do
    (pkgDb, _, _, _) <- initUnits logger dflags Nothing
    pure $ foldMap unitDatabaseUnits 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 <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  [String]
broken <- IO [String] -> Ghc [String]
forall a. IO a -> Ghc a
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
logger <- Ghc Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  [GenUnitInfo UnitId]
db <- IO [GenUnitInfo UnitId] -> Ghc [GenUnitInfo UnitId]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenUnitInfo UnitId] -> Ghc [GenUnitInfo UnitId])
-> IO [GenUnitInfo UnitId] -> Ghc [GenUnitInfo UnitId]
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> HscEnv -> IO [GenUnitInfo UnitId]
getPackageConfigs Logger
logger DynFlags
dflgs HscEnv
hsc_env
  [String]
packageNames <- IO [String] -> Ghc [String]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Ghc [String]) -> IO [String] -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ (GenUnitInfo UnitId -> IO String)
-> [GenUnitInfo UnitId] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Logger -> DynFlags -> HscEnv -> GenUnitInfo UnitId -> IO String
packageIdString' Logger
logger DynFlags
dflgs HscEnv
hsc_env) [GenUnitInfo UnitId]
db
  let hiddenPackages :: Set String
hiddenPackages = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set String
hiddenPackageNames ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
packageNames)
      hiddenFlags :: [PackageFlag]
hiddenFlags = (String -> PackageFlag) -> [String] -> [PackageFlag]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PackageFlag
HidePackage ([String] -> [PackageFlag]) -> [String] -> [PackageFlag]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
hiddenPackages
      initStr :: String
initStr = String
"ihaskell-"
#elif MIN_VERSION_ghc(9,2,0)
  logger <- getLogger
  db <- liftIO $ getPackageConfigs logger dflgs
  packageNames <- liftIO $ mapM (packageIdString' logger dflgs) db
  let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
      hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
      initStr = "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

      -- Name of the ihaskell package, i.e. "ihaskell"
      iHaskellPkgName :: String
iHaskellPkgName = String
"ihaskell"
      displayPkgs :: [String]
displayPkgs = [ String
pkgName
                    | String
pkgName <- [String]
packageNames
                    , Just (Char
x:String
_) <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
initStr String
pkgName]
                    , String
pkgName String -> [String] -> Bool
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
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 Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest

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

      toImportStmt :: String -> String
      toImportStmt :: String -> String
toImportStmt = String -> String -> String
forall r. PrintfType r => String -> r
printf String
importFmt (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineNumber -> [String] -> [String]
forall a. LineNumber -> [a] -> [a]
drop LineNumber
1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
split String
"-"

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

  Ghc () -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> Ghc ()) -> DynFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
dflgs { packageFlags = packageFlags dflgs ++ hiddenFlags }

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

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

  Bool -> Interpreter Bool
forall a. a -> Ghc a
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.
  Ghc ExecResult -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc ExecResult -> Ghc ()) -> Ghc ExecResult -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> ExecOptions -> Ghc ExecResult
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 = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([String -> Bool] -> String -> Bool
forall {t :: * -> *} {p}. Foldable t => t (p -> Bool) -> p -> Bool
fAny [String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
">", String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null]) [String]
l
    fAny :: t (p -> Bool) -> p -> Bool
fAny t (p -> Bool)
fs p
x = ((p -> Bool) -> Bool) -> t (p -> Bool) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((p -> Bool) -> p -> Bool
forall a b. (a -> b) -> a -> b
$ p
x) t (p -> Bool)
fs
    clean :: String
clean = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
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 = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Expected bracket as first char, but got string: " String -> String -> 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
  DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  ([Located CodeBlock]
cmds, DynFlags
flags') <- IO ([Located CodeBlock], DynFlags)
-> Ghc ([Located CodeBlock], DynFlags)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Located CodeBlock], DynFlags)
 -> Ghc ([Located CodeBlock], DynFlags))
-> IO ([Located CodeBlock], DynFlags)
-> Ghc ([Located CodeBlock], DynFlags)
forall a b. (a -> b) -> a -> b
$ (StateT DynFlags IO [Located CodeBlock]
 -> DynFlags -> IO ([Located CodeBlock], DynFlags))
-> DynFlags
-> StateT DynFlags IO [Located CodeBlock]
-> IO ([Located CodeBlock], DynFlags)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT DynFlags IO [Located CodeBlock]
-> DynFlags -> IO ([Located CodeBlock], DynFlags)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT DynFlags
flags (StateT DynFlags IO [Located CodeBlock]
 -> IO ([Located CodeBlock], DynFlags))
-> StateT DynFlags IO [Located CodeBlock]
-> IO ([Located CodeBlock], DynFlags)
forall a b. (a -> b) -> a -> b
$ String -> StateT DynFlags IO [Located CodeBlock]
parseString (String -> String
cleanString String
code)
  Ghc () -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags DynFlags
flags'

  let execCount :: LineNumber
execCount = KernelState -> LineNumber
getExecutionCounter KernelState
kernelState

  -- Extract all parse errors.
  let justError :: CodeBlock -> Maybe CodeBlock
justError x :: CodeBlock
x@ParseError{} = CodeBlock -> Maybe CodeBlock
forall a. a -> Maybe a
Just CodeBlock
x
      justError CodeBlock
_ = Maybe CodeBlock
forall a. Maybe a
Nothing
      errs :: [CodeBlock]
errs = (Located CodeBlock -> Maybe CodeBlock)
-> [Located CodeBlock] -> [CodeBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CodeBlock -> Maybe CodeBlock
justError (CodeBlock -> Maybe CodeBlock)
-> (Located CodeBlock -> CodeBlock)
-> Located CodeBlock
-> Maybe CodeBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located CodeBlock -> CodeBlock
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
                 Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KernelState -> LintStatus
getLintStatus KernelState
kernelState LintStatus -> LintStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= LintStatus
LintOff) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
                   Display
lintSuggestions <- String -> [Located CodeBlock] -> IO Display
lint String
code [Located CodeBlock]
cmds
                   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Display -> Bool
noResults Display
lintSuggestions) (IO () -> IO ()) -> IO () -> IO ()
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 ((Located CodeBlock -> CodeBlock)
-> [Located CodeBlock] -> [CodeBlock]
forall a b. (a -> b) -> [a] -> [b]
map Located CodeBlock -> CodeBlock
forall a. Located a -> a
unloc [Located CodeBlock]
cmds [CodeBlock] -> [CodeBlock] -> [CodeBlock]
forall a. [a] -> [a] -> [a]
++ [LineNumber -> CodeBlock
forall {t}. PrintfArg t => t -> CodeBlock
storeItCommand LineNumber
execCount])
               -- Print all parse errors.
               [CodeBlock]
_ -> do
                 [CodeBlock] -> (CodeBlock -> Ghc ()) -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CodeBlock]
errs ((CodeBlock -> Ghc ()) -> Ghc ())
-> (CodeBlock -> Ghc ()) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \CodeBlock
err -> do
                   EvalOut
out <- Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output CodeBlock
err KernelState
kernelState
                   IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Publisher
output
                     (Display -> [DisplayData] -> [WidgetMsg] -> EvaluationResult
FinalResult (EvalOut -> Display
evalResult EvalOut
out) [] [])
                     (EvalOut -> ErrorOccurred
evalStatus EvalOut
out)
                 (KernelState, ErrorOccurred)
-> Interpreter (KernelState, ErrorOccurred)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
kernelState, ErrorOccurred
Failure)

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

  where
    noResults :: Display -> Bool
noResults (Display [DisplayData]
res) = [DisplayData] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DisplayData]
res
    noResults (ManyDisplay [Display]
res) = (Display -> Bool) -> [Display] -> Bool
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 [] = (KernelState, ErrorOccurred)
-> Interpreter (KernelState, ErrorOccurred)
forall a. a -> Ghc a
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 <- String -> Interpreter (Either String (IO ByteString))
forall a. Typeable a => String -> Interpreter (Either String a)
extractValue String
"IHaskell.Display.displayFromChanEncoded"
                      case Either String (IO ByteString)
getEncodedDisplays of
                        Left String
err -> String -> Ghc (Maybe Display)
forall a. HasCallStack => String -> a
error (String -> Ghc (Maybe Display)) -> String -> Ghc (Maybe Display)
forall a b. (a -> b) -> a -> b
$ String
"Deserialization error (Evaluate.hs): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                        Right IO ByteString
displaysIO -> do
                          ByteString
result <- IO ByteString -> Ghc ByteString
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
displaysIO
                          case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, Maybe Display)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Binary.decodeOrFail ByteString
result of
                            Left (ByteString
_, ByteOffset
_, String
err) -> String -> Ghc (Maybe Display)
forall a. HasCallStack => String -> a
error (String -> Ghc (Maybe Display)) -> String -> Ghc (Maybe Display)
forall a b. (a -> b) -> a -> b
$ String
"Deserialization error (Evaluate.hs): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                            Right (ByteString
_, ByteOffset
_, Maybe Display
res) -> Maybe Display -> Ghc (Maybe Display)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Display
res
                    else Maybe Display -> Ghc (Maybe Display)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Display
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 Display -> Display -> Display
forall a. Semigroup a => a -> a -> a
<> Display
disps

      -- Output things only if they are non-empty.
      Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Display -> Bool
noResults Display
result Bool -> Bool -> Bool
&& [DisplayData] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EvalOut -> [DisplayData]
evalPager EvalOut
evalOut)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$
        IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
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 = [] }

      -- 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 KernelState -> Interpreter KernelState
forall a. a -> Ghc a
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 -> (KernelState, ErrorOccurred)
-> Interpreter (KernelState, ErrorOccurred)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (KernelState
newState, ErrorOccurred
Failure)

    storeItCommand :: t -> CodeBlock
storeItCommand t
execCount = String -> CodeBlock
Statement (String -> CodeBlock) -> String -> CodeBlock
forall a b. (a -> b) -> a -> b
$ String -> t -> String
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
#if MIN_VERSION_ghc(9,0,0)
  Either String Dynamic
compiled <- Ghc (Either String Dynamic)
-> (SomeException -> Ghc (Either String Dynamic))
-> Ghc (Either String Dynamic)
forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (Dynamic -> Either String Dynamic
forall a b. b -> Either a b
Right (Dynamic -> Either String Dynamic)
-> Ghc Dynamic -> Ghc (Either String Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc Dynamic
forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
expr) (\SomeException
exc -> Either String Dynamic -> Ghc (Either String Dynamic)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String Dynamic
forall a b. a -> Either a b
Left (SomeException -> String
forall a. Show a => a -> String
show SomeException
exc)))
  case Either String Dynamic
compiled of
    Left String
exc -> Either String a -> Interpreter (Either String a)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
exc)
    Right Dynamic
dyn -> case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
      Maybe a
Nothing     -> Either String a -> Interpreter (Either String a)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
multipleIHaskells)
      Just a
result -> Either String a -> Interpreter (Either String a)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either String a
forall a b. b -> Either a b
Right a
result)
#else
  compiled <- dynCompileExpr expr
  case fromDynamic compiled of
    Nothing     -> return (Left multipleIHaskells)
    Just result -> return (Right result)
#endif

  where
    multipleIHaskells :: String
multipleIHaskells =
      [String] -> String
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 <- String -> Interpreter (Either String (IO [WidgetMsg]))
forall a. Typeable a => String -> Interpreter (Either String a)
extractValue String
"IHaskell.Eval.Widgets.relayWidgetMessages"
  IO KernelState -> Interpreter KernelState
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KernelState -> Interpreter KernelState)
-> IO KernelState -> Interpreter KernelState
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
        KernelState -> IO KernelState
forall a. a -> IO a
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 [WidgetMsg] -> [WidgetMsg] -> [WidgetMsg]
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 :: forall e. Diagnostic e => MsgEnvelope e -> SDoc
getErrMsgDoc = MsgEnvelope e -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
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 = 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 = (SomeException -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SomeException -> Interpreter EvalOut
handler (Interpreter EvalOut -> Interpreter EvalOut)
-> (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut
-> Interpreter EvalOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceError -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
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 =
      EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
          , evalResult :: Display
evalResult = String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ SomeException -> String
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 :: [MsgEnvelope GhcMessage]
msgs = Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> Messages GhcMessage
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages GhcMessage -> [MsgEnvelope GhcMessage])
-> Messages GhcMessage -> [MsgEnvelope GhcMessage]
forall a b. (a -> b) -> a -> b
$ SourceError -> Messages GhcMessage
srcErrorMessages SourceError
srcerr
#else
      let msgs = bagToList $ srcErrorMessages srcerr
#endif
      [String]
errStrs <- [MsgEnvelope GhcMessage]
-> (MsgEnvelope GhcMessage -> Ghc String) -> Ghc [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [MsgEnvelope GhcMessage]
msgs ((MsgEnvelope GhcMessage -> Ghc String) -> Ghc [String])
-> (MsgEnvelope GhcMessage -> Ghc String) -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ SDoc -> Ghc String
forall (m :: * -> *). GhcMonad m => SDoc -> m String
doc (SDoc -> Ghc String)
-> (MsgEnvelope GhcMessage -> SDoc)
-> MsgEnvelope GhcMessage
-> Ghc String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope GhcMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
getErrMsgDoc

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

      EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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 (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$
  Interpreter Display
exec Interpreter Display
-> (Display -> Interpreter EvalOut) -> Interpreter EvalOut
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
res ->
    EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Import: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
importStr
  String -> Ghc ()
forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
importStr
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Display
forall a. Monoid a => a
mempty

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

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

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

  -- Remember which modules we've loaded before.
  [InteractiveImport]
importedModules <- Ghc [InteractiveImport]
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
"." (String -> [String])
-> (ImportDecl GhcPs -> String) -> ImportDecl GhcPs -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString (ModuleName -> String)
-> (ImportDecl GhcPs -> ModuleName) -> ImportDecl GhcPs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> XRec GhcPs ModuleName
ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcPs -> [String]) -> ImportDecl GhcPs -> [String]
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
decl
      moduleNameOf (IIModule ModuleName
imp) = String -> String -> [String]
split String
"." (String -> [String])
-> (ModuleName -> String) -> ModuleName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString (ModuleName -> [String]) -> ModuleName -> [String]
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 [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
namePieces String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
pieces Bool -> Bool -> Bool
&& [String]
namePieces [String] -> [String] -> Bool
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 (InteractiveImport -> Bool)
-> [InteractiveImport] -> Maybe InteractiveImport
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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." (InteractiveImport -> [String]
moduleNameOf InteractiveImport
previous)
      Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$
        String -> String -> String -> String
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 (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"All Flags: " String -> String -> String
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 (KernelOpt -> KernelState -> KernelState)
-> Maybe KernelOpt -> Maybe (KernelState -> KernelState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KernelOpt -> Bool) -> [KernelOpt] -> Maybe KernelOpt
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
flag ([String] -> Bool) -> (KernelOpt -> [String]) -> KernelOpt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelOpt -> [String]
getSetName) [KernelOpt]
kernelOpts

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

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

  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
flags
    then do
      DynFlags
flgs <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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 -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
flgs (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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' = ((KernelState -> KernelState)
 -> (KernelState -> KernelState) -> KernelState -> KernelState)
-> (KernelState -> KernelState)
-> [KernelState -> KernelState]
-> KernelState
-> KernelState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (KernelState -> KernelState)
-> (KernelState -> KernelState) -> KernelState -> KernelState
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) KernelState -> KernelState
forall a. a -> a
id ((String -> Maybe (KernelState -> KernelState))
-> [String] -> [KernelState -> KernelState]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater [String]
ihaskellFlags) KernelState
state
      [String]
errs <- [String] -> Ghc [String]
forall (m :: * -> *). GhcMonad m => [String] -> m [String]
setFlags [String]
ghcFlags
      let disp :: Display
disp =
            case [String]
errs of
              [] -> Display
forall a. Monoid a => a
mempty
              [String]
_  -> String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
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" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags
        then String -> Ghc ()
forall (m :: * -> *). GhcMonad m => String -> m ()
evalImport String
"import qualified Prelude as Prelude"
        else Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"-XImplicitPrelude" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
          ImportDecl GhcPs
importDecl <- String -> Ghc (ImportDecl GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
"import Prelude"
#if MIN_VERSION_ghc(9,6,0)
          let implicitPrelude :: ImportDecl GhcPs
implicitPrelude = ImportDecl GhcPs
importDecl { ideclExt = (ideclExt importDecl) { ideclImplicit = True } }
#else
          let implicitPrelude = importDecl { ideclImplicit = True }
#endif
          [InteractiveImport]
imports <- Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
          [InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport] -> Ghc ()) -> [InteractiveImport] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
implicitPrelude InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: [InteractiveImport]
imports

      EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opts
  let set :: String
set = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
" -X" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> String) -> [String] -> String
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Load Module: " String -> String -> String
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)

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

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

evalCommand Publisher
_output (Directive DirectiveType
SetOption String
opts) KernelState
state = do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Option: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opts
  let nonExisting :: [String]
nonExisting = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
optionExists) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
opts
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
nonExisting
    then let err :: String
err = String
"No such options: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
nonExisting
         in EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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 = (String -> Maybe KernelOpt) -> [String] -> [KernelOpt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe KernelOpt
findOption ([String] -> [KernelOpt]) -> [String] -> [KernelOpt]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
opts
             updater :: KernelState -> KernelState
updater = ((KernelState -> KernelState)
 -> (KernelState -> KernelState) -> KernelState -> KernelState)
-> (KernelState -> KernelState)
-> [KernelState -> KernelState]
-> KernelState
-> KernelState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (KernelState -> KernelState)
-> (KernelState -> KernelState) -> KernelState -> KernelState
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) KernelState -> KernelState
forall a. a -> a
id ([KernelState -> KernelState] -> KernelState -> KernelState)
-> [KernelState -> KernelState] -> KernelState -> KernelState
forall a b. (a -> b) -> a -> b
$ (KernelOpt -> KernelState -> KernelState)
-> [KernelOpt] -> [KernelState -> KernelState]
forall a b. (a -> b) -> [a] -> [b]
map KernelOpt -> KernelState -> KernelState
getUpdateKernelState [KernelOpt]
options
         in EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return
              EvalOut
                { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
                , evalResult :: Display
evalResult = Display
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 = Maybe KernelOpt -> Bool
forall a. Maybe a -> Bool
isJust (Maybe KernelOpt -> Bool)
-> (String -> Maybe KernelOpt) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe KernelOpt
findOption
    findOption :: String -> Maybe KernelOpt
findOption String
opt =
      (KernelOpt -> Bool) -> [KernelOpt] -> Maybe KernelOpt
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
opt ([String] -> Bool) -> (KernelOpt -> [String]) -> KernelOpt -> Bool
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr
  String -> Display
formatType (String -> Display) -> (String -> String) -> String -> Display
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> Display) -> Ghc String -> Interpreter Display
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc String
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Kind: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr
  (Kind
_, Kind
kind) <- Bool -> String -> Ghc (Kind, Kind)
forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
GHC.typeKind Bool
False String
expr
  DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let typeStr :: String
typeStr = DynFlags -> SDoc -> String
showSDocUnqual DynFlags
flags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
kind
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
formatType (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ String
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> 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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Kind!: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr
  (Kind
typ, Kind
kind) <- Bool -> String -> Ghc (Kind, Kind)
forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Kind, Kind)
GHC.typeKind Bool
True String
expr
  DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  let kindStr :: SDoc
kindStr = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
kind
  let typeStr :: SDoc
typeStr = SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
typ
  let finalStr :: String
finalStr = DynFlags -> SDoc -> String
showSDocUnqual DynFlags
flags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc
kindStr, SDoc
typeStr]
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Load: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
names

  [Display]
displays <- [String] -> (String -> Interpreter Display) -> Ghc [Display]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (String -> [String]
words String
names) ((String -> Interpreter Display) -> Ghc [Display])
-> (String -> Interpreter Display) -> Ghc [Display]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
                let filename :: String
filename = if String
".hs" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
name
                                 then String
name
                                 else String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs"
                String
contents <- IO String -> Ghc String
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Ghc String) -> IO String -> Ghc String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
filename
                String
modName <- String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> Ghc [String] -> Ghc String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc [String]
forall (m :: * -> *). GhcMonad m => String -> m [String]
getModuleName String
contents
                String -> String -> Interpreter Display
doLoadModule String
filename String
modName
  Display -> Interpreter Display
forall a. a -> Ghc a
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$
  -- Assume the first character of 'cmd' is '!'.
  case String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ LineNumber -> String -> String
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 <- IO (Either SomeException String)
-> Ghc (Either SomeException String)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO (Either SomeException String)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
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 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
dirs
      Bool
exists <- IO Bool -> Interpreter Bool
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Interpreter Bool) -> IO Bool -> Interpreter Bool
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.
          IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
directory

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

          -- Maximum size of the output (after which we truncate).
          maxSize :: LineNumber
maxSize = LineNumber
100 LineNumber -> LineNumber -> LineNumber
forall a. Num a => a -> a -> a
* LineNumber
1000
          incSize :: LineNumber
incSize = LineNumber
200
          output :: String -> ErrorOccurred -> IO ()
output String
str = Publisher
publish Publisher -> Publisher
forall a b. (a -> b) -> a -> b
$ Display -> EvaluationResult
IntermediateResult (Display -> EvaluationResult) -> Display -> EvaluationResult
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
            MVar String -> (String -> IO String) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
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.
                MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
outputAccum IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ErrorOccurred -> IO ())
-> ErrorOccurred -> String -> IO ()
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
                MVar String -> (String -> IO String) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
next))
                String
out <- MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
outputAccum
                case ExitCode
exitCode of
                  ExitCode
ExitSuccess -> Display -> IO Display
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> IO Display) -> Display -> IO Display
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNumber -> String
forall a. Show a => a -> String
show LineNumber
code
                    Display -> IO Display
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> IO Display) -> Display -> IO Display
forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
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
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Help via :help or :?."
  EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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 (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
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 (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Info: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
  -- Get all the info for all the names we're given.
  String
strings <- [String] -> String
unlines ([String] -> String) -> Ghc [String] -> Ghc String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc [String]
forall (m :: * -> *). GhcMonad m => String -> m [String]
getDescription String
str

  EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
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
          , Maybe Text -> Text -> String -> DisplayData
htmlify (String -> Text
Text.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KernelState -> Maybe String
htmlCodeWrapperClass KernelState
state)
                    (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ KernelState -> String
htmlCodeTokenPrefix KernelState
state)
                    String
strings
          ]
      , 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 (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  [HoogleResult]
results <- IO [HoogleResult] -> Ghc [HoogleResult]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HoogleResult] -> Ghc [HoogleResult])
-> IO [HoogleResult] -> Ghc [HoogleResult]
forall a b. (a -> b) -> a -> b
$ String -> IO [HoogleResult]
Hoogle.search String
query
  EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvalOut -> Interpreter EvalOut) -> EvalOut -> Interpreter EvalOut
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 (Interpreter EvalOut -> Interpreter EvalOut)
-> Interpreter EvalOut -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  [HoogleResult]
results <- IO [HoogleResult] -> Ghc [HoogleResult]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HoogleResult] -> Ghc [HoogleResult])
-> IO [HoogleResult] -> Ghc [HoogleResult]
forall a b. (a -> b) -> a -> b
$ String -> IO [HoogleResult]
Hoogle.document String
query
  EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvalOut -> Interpreter EvalOut) -> EvalOut -> Interpreter EvalOut
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  IORef [String]
contents <- IO (IORef [String]) -> Ghc (IORef [String])
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [String]) -> Ghc (IORef [String]))
-> IO (IORef [String]) -> Ghc (IORef [String])
forall a b. (a -> b) -> a -> b
$ [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
#if MIN_VERSION_ghc(9,4,0)
  let action :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
action = \LogFlags
_lflags MessageClass
_msgclass SrcSpan
_srcspan SDoc
msg -> IORef [String] -> ([String] -> [String]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [String]
contents (DynFlags -> SDoc -> String
showSDoc DynFlags
flags SDoc
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
#elif MIN_VERSION_ghc(9,0,0)
  let action = \_dflags _warn _sev _srcspan msg -> modifyIORef' contents (showSDoc flags msg :)
#else
  let action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' contents (showSDoc flags msg :)
#endif
#if MIN_VERSION_ghc(9,2,0)
  ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> Ghc ()
forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
action)
#else
  let flags' = flags { log_action = action }
  _ <- setSessionDynFlags flags'
#endif
  Bool -> Bool -> String -> Ghc ()
forall (m :: * -> *). GhcMonad m => Bool -> Bool -> String -> m ()
Debugger.pprintClosureCommand Bool
False Bool
False String
binding
#if MIN_VERSION_ghc(9,2,0)
  Ghc ()
forall (m :: * -> *). GhcMonad m => m ()
popLogHookM
#endif
  ()
_ <- DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags DynFlags
flags
  [String]
sprint <- IO [String] -> Ghc [String]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Ghc [String]) -> IO [String] -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
contents
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ Publisher -> KernelState -> Captured Any -> Interpreter Display
forall a.
Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO Publisher
output KernelState
state
                                                                    (String -> Captured Any
forall a. String -> Captured a
CapturedStmt String
stmt)

evalCommand Publisher
output (Expression String
expr) KernelState
state = do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Expression:\n" String -> String -> String
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 = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"(IHaskell.Display.display (%s))" String
expr :: String
  Bool
canRunDisplay <- Interpreter Kind -> Interpreter Bool
forall a. Interpreter a -> Interpreter Bool
attempt (Interpreter Kind -> Interpreter Bool)
-> Interpreter Kind -> Interpreter Bool
forall a b. (a -> b) -> a -> b
$ TcRnExprMode -> String -> Interpreter Kind
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
displayExpr

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

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

  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Can Display: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
canRunDisplay
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Is Widget: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
isWidget
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Is Declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
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
      ()
_ <- KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Suppressing display for template haskell declaration"
      [Name]
_ <- String -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
GHC.runDecls String
expr
      EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return
        EvalOut
          { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Success
          , evalResult :: Display
evalResult = Display
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.
             EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvalOut -> Interpreter EvalOut) -> EvalOut -> Interpreter EvalOut
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 = Interpreter Bool
-> (SomeException -> Interpreter Bool) -> Interpreter Bool
forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (Interpreter a
action Interpreter a -> Interpreter Bool -> Interpreter Bool
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Interpreter Bool
forall a. a -> Ghc a
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
_ = Bool -> Interpreter Bool
forall a. a -> Ghc a
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" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
msg Bool -> Bool -> Bool
&&
      String -> String -> 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 MimeType -> MimeType -> Bool
forall a. Eq a => a -> a -> Bool
== MimeType
MimeSvg

    removeSvg :: Display -> Display
    removeSvg :: Display -> Display
removeSvg (Display [DisplayData]
disps) = [DisplayData] -> Display
Display ([DisplayData] -> Display) -> [DisplayData] -> Display
forall a b. (a -> b) -> a -> b
$ (DisplayData -> Bool) -> [DisplayData] -> [DisplayData]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DisplayData -> Bool) -> DisplayData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayData -> Bool
isSvg) [DisplayData]
disps
    removeSvg (ManyDisplay [Display]
disps) = [Display] -> Display
ManyDisplay ([Display] -> Display) -> [Display] -> Display
forall a b. (a -> b) -> a -> b
$ (Display -> Display) -> [Display] -> [Display]
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 <- String -> Interpreter Bool
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 (String -> CodeBlock) -> String -> CodeBlock
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
stmtTemplate String
expr) KernelState
state
      case EvalOut -> ErrorOccurred
evalStatus EvalOut
evalOut of
        ErrorOccurred
Failure -> EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return EvalOut
evalOut
        ErrorOccurred
Success -> KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
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 <- String -> Ghc Dynamic
forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
cexpr

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

    isIO :: t -> Interpreter Bool
isIO t
exp = Interpreter Kind -> Interpreter Bool
forall a. Interpreter a -> Interpreter Bool
attempt (Interpreter Kind -> Interpreter Bool)
-> Interpreter Kind -> Interpreter Bool
forall a b. (a -> b) -> a -> b
$ TcRnExprMode -> String -> Interpreter Kind
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst (String -> Interpreter Kind) -> String -> Interpreter Kind
forall a b. (a -> b) -> a -> b
$ String -> t -> String
forall r. PrintfType r => String -> r
printf String
"((\\x -> x) :: IO a -> IO a) (%s)" t
exp

    postprocessShowError :: EvalOut -> EvalOut
    postprocessShowError :: EvalOut -> EvalOut
postprocessShowError EvalOut
evalOut = EvalOut
evalOut { evalResult = Display $ map postprocess 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' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ do
          let pieces :: [String]
pieces = String -> [String]
words String
txt
              before :: [String]
before = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"arising") [String]
pieces
              after :: String
after = String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"(Show") [String]
before

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


evalCommand Publisher
_ (Declaration String
decl) KernelState
state = KernelState -> Interpreter Display -> Interpreter EvalOut
wrapExecution KernelState
state (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$ do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Declaration:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
decl
  [String]
boundNames <- String -> Ghc [String]
forall (m :: * -> *). GhcMonad m => String -> m [String]
evalDeclarations String
decl
  let nonDataNames :: [String]
nonDataNames = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper (Char -> Bool) -> (String -> Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. HasCallStack => [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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ KernelState -> Bool
useShowTypes KernelState
state
    then Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Display
forall a. Monoid a => a
mempty
    else do
      -- Get all the type strings.
      DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      [String]
types <- [String] -> (String -> Ghc String) -> Ghc [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
nonDataNames ((String -> Ghc String) -> Ghc [String])
-> (String -> Ghc String) -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
                 String
theType <- DynFlags -> SDoc -> String
showSDocUnqual DynFlags
dflags (SDoc -> String) -> (Kind -> SDoc) -> Kind -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Kind -> String) -> Interpreter Kind -> Ghc String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnExprMode -> String -> Interpreter Kind
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
name
                 String -> Ghc String
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ghc String) -> String -> Ghc String
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
theType

      Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [Maybe Text -> String -> DisplayData
html' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
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.
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ String
"The type signature " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sig String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nlacks an accompanying binding."

evalCommand Publisher
_ (ParseError StringLoc
loc String
err) KernelState
state = do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state String
"Parse Error."
  EvalOut -> Interpreter EvalOut
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return
    EvalOut
      { evalStatus :: ErrorOccurred
evalStatus = ErrorOccurred
Failure
      , evalResult :: Display
evalResult = String -> Display
displayError (String -> Display) -> String -> Display
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 (Interpreter Display -> Interpreter EvalOut)
-> Interpreter Display -> Interpreter EvalOut
forall a b. (a -> b) -> a -> b
$
  Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ String
"Pragmas of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pragmaType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nare not supported."

evalCommand Publisher
output (Pragma PragmaType
PragmaLanguage [String]
pragmas) KernelState
state = do
  KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Got LANGUAGE pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
pragmas
  Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand Publisher
output (DirectiveType -> String -> CodeBlock
Directive DirectiveType
SetExtension (String -> CodeBlock) -> String -> CodeBlock
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 = Display
forall a. Monoid a => a
mempty
    , evalState :: KernelState
evalState = KernelState
state
    , evalPager :: [DisplayData]
evalPager = [ String -> DisplayData
plain (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (HoogleResult -> String) -> [HoogleResult] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OutputFormat -> HoogleResult -> String
Hoogle.render OutputFormat
Hoogle.Plain) [HoogleResult]
results
                  , Maybe Text -> String -> DisplayData
html' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (HoogleResult -> String) -> [HoogleResult] -> [String]
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 <- Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

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

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

    -- Add imports
    [InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport] -> Ghc ()) -> [InteractiveImport] -> Ghc ()
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 (ModuleName -> ImportDecl GhcPs) -> ModuleName -> ImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ String -> ModuleName
mkModuleName String
modName) InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: [InteractiveImport]
importedModules

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

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

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

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

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

      Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
displayError (String -> Display) -> String -> Display
forall a b. (a -> b) -> a -> b
$ String
"Failed to load module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
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 <- Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

  (Interpreter Display
 -> (SomeException -> Interpreter Display) -> Interpreter Display)
-> (SomeException -> Interpreter Display)
-> Interpreter Display
-> Interpreter Display
forall a b c. (a -> b -> c) -> b -> a -> c
flip Interpreter Display
-> (SomeException -> Interpreter Display) -> Interpreter Display
forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch ([InteractiveImport] -> SomeException -> Interpreter Display
unload [InteractiveImport]
importedModules) (Interpreter Display -> Interpreter Display)
-> Interpreter Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ do
    -- Compile loaded modules.
    DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    IORef [String]
errRef <- IO (IORef [String]) -> Ghc (IORef [String])
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [String]) -> Ghc (IORef [String]))
-> IO (IORef [String]) -> Ghc (IORef [String])
forall a b. (a -> b) -> a -> b
$ [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
    ()
_ <- DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> Ghc ()) -> DynFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
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 = objTarget 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 <- Ghc [Target]
forall (m :: * -> *). GhcMonad m => m [Target]
getTargets
    SuccessFlag
result <- LoadHowMuch -> Ghc SuccessFlag
forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f 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      -> [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
oldTargets
      Succeeded{} -> () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

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

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

      Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ String -> Display
displayError (String -> Display) -> String -> Display
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 (Platform -> Backend)
-> (DynFlags -> Platform) -> DynFlags -> Backend
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 <- IO StdGen -> Ghc StdGen
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
  let
      -- Variable names generation.
      rand :: String
rand = LineNumber -> String -> String
forall a. LineNumber -> [a] -> [a]
take LineNumber
20 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char, Char) -> StdGen -> String
forall g. RandomGen g => (Char, Char) -> g -> String
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 String -> String -> String
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 = String -> r
forall r. PrintfType r => String -> r
printf (String -> r) -> String -> r
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" IHaskellPrelude.>> IHaskellPrelude.return ()"

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

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

      goStmt :: String -> Ghc ExecResult
      goStmt :: String -> Ghc ExecResult
goStmt String
s = String -> ExecOptions -> Ghc ExecResult
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 <- Ghc AnyException
-> (SomeException -> Ghc AnyException) -> Ghc AnyException
forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (IO a -> Ghc a
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io Ghc a -> Ghc AnyException -> Ghc AnyException
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AnyException -> Ghc AnyException
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return AnyException
NoException) (AnyException -> Ghc AnyException
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyException -> Ghc AnyException)
-> (SomeException -> AnyException)
-> SomeException
-> Ghc AnyException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> AnyException
AnyException)
        ExecResult -> Ghc ExecResult
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExecResult -> Ghc ExecResult) -> ExecResult -> Ghc ExecResult
forall a b. (a -> b) -> a -> b
$
          case AnyException
stat of
            AnyException
NoException    -> Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right []) Word64
0
            AnyException SomeException
e -> Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete (SomeException -> Either SomeException [Name]
forall a b. a -> Either a b
Left SomeException
e)   Word64
0

  -- Initialize evaluation context.
  [String] -> (String -> Ghc ExecResult) -> Ghc ()
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 <- String -> Ghc Dynamic
forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr String
readVariable
  Handle
pipe <- case Dynamic -> Maybe Fd
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
            Maybe Fd
Nothing -> String -> Ghc Handle
forall a. HasCallStack => String -> a
error String
"Evaluate: Bad pipe"
            Just Fd
fd -> IO Handle -> Ghc Handle
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> Ghc Handle) -> IO Handle -> Ghc Handle
forall a b. (a -> b) -> a -> b
$ do
                Handle
hdl <- Fd -> IO Handle
fdToHandle Fd
fd
                Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hdl TextEncoding
utf8
                Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
hdl

  -- Keep track of whether execution has completed.
  MVar Bool
completed <- IO (MVar Bool) -> Ghc (MVar Bool)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Bool) -> Ghc (MVar Bool))
-> IO (MVar Bool) -> Ghc (MVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False
  MVar Bool
finishedReading <- IO (MVar Bool) -> Ghc (MVar Bool)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
  MVar String
outputAccum <- IO (MVar String) -> Ghc (MVar String)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar String) -> Ghc (MVar String))
-> IO (MVar String) -> Ghc (MVar String)
forall a b. (a -> b) -> a -> b
$ String -> IO (MVar String)
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 LineNumber -> LineNumber -> LineNumber
forall a. Num a => a -> a -> a
* LineNumber
ms

      -- Maximum size of the output (after which we truncate).
      maxSize :: LineNumber
maxSize = LineNumber
100 LineNumber -> LineNumber -> LineNumber
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 <- MVar Bool -> IO Bool
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
            MVar String -> (String -> IO String) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextChunk))

            -- Write to frontend and repeat.
            MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
outputAccum IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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
            MVar String -> (String -> IO String) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar String
outputAccum (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextChunk))

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

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

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

              -- Finalize evaluation context.
              Ghc [ExecResult] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [ExecResult] -> Ghc ()) -> Ghc [ExecResult] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> Ghc ExecResult) -> Ghc [ExecResult]
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.
              IO Bool -> Interpreter Bool
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Interpreter Bool) -> IO Bool -> Interpreter Bool
forall a b. (a -> b) -> a -> b
$ MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
finishedReading

  String
printedOutput <- IO String -> Ghc String
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Ghc String) -> IO String -> Ghc String
forall a b. (a -> b) -> a -> b
$ MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
outputAccum
  (String, ExecResult) -> Interpreter (String, ExecResult)
forall a. a -> Ghc a
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 = Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display)
-> (SomeException -> Display)
-> SomeException
-> Interpreter Display
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Display
displayError (String -> Display)
-> (SomeException -> String) -> SomeException -> Display
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
      handler :: SomeException -> Interpreter Display
handler e :: SomeException
e@SomeException{} = SomeException -> Interpreter Display
showError SomeException
e
  Interpreter Display
-> (SomeException -> Interpreter Display) -> Interpreter Display
forall a. Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch (Publisher -> KernelState -> Captured a -> Interpreter Display
forall a.
Publisher -> KernelState -> Captured a -> Interpreter Display
evalStatementOrIO Publisher
publish KernelState
state (IO a -> Captured a
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 Publisher
-> (Display -> EvaluationResult)
-> Display
-> ErrorOccurred
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> EvaluationResult
IntermediateResult (Display -> ErrorOccurred -> IO ())
-> Display -> ErrorOccurred -> IO ()
forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [String -> DisplayData
plain String
str]

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

  (String
printed, ExecResult
result) <- (String -> IO ()) -> Captured a -> Interpreter (String, ExecResult)
forall a.
(String -> IO ()) -> Captured a -> Interpreter (String, ExecResult)
capturedEval ((String -> ErrorOccurred -> IO ())
-> ErrorOccurred -> String -> IO ()
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 <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags

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

      KernelState -> String -> Ghc ()
forall (m :: * -> *).
(MonadIO m, GhcMonad m) =>
KernelState -> String -> m ()
write KernelState
state (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String
"Names: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ KernelState -> Bool
useShowTypes KernelState
state
        then Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [DisplayData]
oput
        else do
          -- Get all the type strings.
          [String]
types <- [String] -> (String -> Ghc String) -> Ghc [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
nonItNames ((String -> Ghc String) -> Ghc [String])
-> (String -> Ghc String) -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
                     String
theType <- DynFlags -> SDoc -> String
showSDocUnqual DynFlags
dflags (SDoc -> String) -> (Kind -> SDoc) -> Kind -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Kind -> String) -> Interpreter Kind -> Ghc String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnExprMode -> String -> Interpreter Kind
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Kind
exprType TcRnExprMode
TM_Inst String
name
                     String -> Ghc String
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ghc String) -> String -> Ghc String
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
theType

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

          Display -> Interpreter Display
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> Interpreter Display) -> Display -> Interpreter Display
forall a b. (a -> b) -> a -> b
$
            case [DisplayData] -> String
extractPlain [DisplayData]
oput of
              String
"" -> [DisplayData] -> Display
Display [Maybe Text -> String -> DisplayData
html' (Text -> Maybe Text
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 (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String
joined String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
txt, Maybe Text -> String -> DisplayData
html' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String
htmled String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mono String
txt]

    ExecComplete (Left SomeException
exception) Word64
_ -> SomeException -> Interpreter Display
forall a. SomeException -> Ghc a
throw SomeException
exception
    ExecBreak{} -> String -> Interpreter Display
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.
  String -> IO String
forall a. a -> IO a
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 <- IO Char -> IO (Either SomeException Char)
forall a. IO a -> IO (Either SomeException a)
gtry (IO Char -> IO (Either SomeException Char))
-> IO Char -> IO (Either SomeException Char)
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 Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
delims
        then String -> IO String
forall a. a -> IO a
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 LineNumber -> LineNumber -> LineNumber
forall a. Num a => a -> a -> a
- LineNumber
1)
          String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Char
ch Char -> String -> String
forall a. a -> [a] -> [a]
: String
next
    -- An error occurs at the end of the stream, so just stop reading.
    Left SomeException
_ -> String -> IO String
forall a. a -> IO a
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 =
  String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"<span class='%s'>%s</span>" String
cls (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"\n" String
"<br/>" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String
fixDollarSigns (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"<" String
"&lt;" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
">" String
"&gt;" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"&" String
"&amp;" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
useDashV String
"" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"Ghci" String
"IHaskell" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> String -> String
replace String
"‘interactive:" String
"‘" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String
rstrip (String -> String) -> (String -> String) -> String -> String
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) =
  String -> LineNumber -> LineNumber -> String -> String
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 = String -> String -> String
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' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
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 (String -> DisplayData)
-> (String -> String) -> String -> DisplayData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
typeCleaner (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String
msg, Maybe Text -> String -> DisplayData
html' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ihaskellCSS) (String -> DisplayData) -> String -> DisplayData
forall a b. (a -> b) -> a -> b
$ String -> String
formatError String
msg]

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