{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------

module Clash.GHCi.UI (
        interactiveUI,
        GhciSettings(..),
        defaultGhciSettings,
        ghciCommands,
        ghciWelcomeMsg,
        makeHDL
    ) where

#include "HsVersions.h"

-- GHCi
import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
import Clash.GHCi.UI.Monad hiding ( args, runStmt )
import Clash.GHCi.UI.Tags
import Clash.GHCi.UI.Info
import Debugger

-- The GHC interface
import GHCi
import GHCi.RemoteTypes
import GHCi.BreakArray
import DynFlags
import ErrUtils hiding (traceCmd)
import Finder
import GhcMonad ( modifySession )
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
             GetDocsFailure(..),
             getModuleGraph, handleSourceError )
import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)
import GHC.Hs.ImpExp
import GHC.Hs
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,
                  hsc_dynLinker )
import Module
import Name
import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
                  listVisibleModuleNames, pprFlag )
import IfaceSyn ( showToHeader )
import PprTyThing
import PrelNames
import RdrName ( getGRE_NameQualifier_maybes, getRdrName )
import SrcLoc
import qualified Lexer

import StringBuffer
import Outputable hiding ( printForUser, printForUserPartWay )

import DynamicLoading ( initializePlugins )

-- Other random utilities
import BasicTypes hiding ( isTopLevel )
import Digraph
import Encoding
import FastString
import Linker
import Maybes ( orElse, expectJust )
import NameSet
import Panic hiding ( showException )
import Util
import qualified GHC.LanguageExtensions as LangExt
import Bag (unitBag)

-- Haskell Libraries
import System.Console.Haskeline as Haskeline

import Control.Applicative hiding (empty)
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except

import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf,
                   isSuffixOf, nub, partition, sort, sortBy, (\\) )
import Data.Proxy
import qualified Data.Set as S
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IntMap
import Data.Time.LocalTime ( getZonedTime )
import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
import Prelude hiding ((<>))

import Exception hiding (catch)
import Foreign hiding (void)
import GHC.Stack hiding (SrcLoc(..))

import System.Directory
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.FilePath
import System.Info
import System.IO
import System.IO.Error
import System.IO.Unsafe ( unsafePerformIO )
import System.Process
import Text.Printf
import Text.Read ( readMaybe )
import Text.Read.Lex (isSymbolChar)

import Unsafe.Coerce

#if !defined(mingw32_HOST_OS)
import System.Posix hiding ( getEnv )
#else
import qualified System.Win32
#endif

import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
import GHC.TopHandler ( topHandler )

import Clash.GHCi.Leak

-- clash additions
import           Clash.Backend (Backend(initBackend, hdlKind, primDirs))
import           Clash.Backend.SystemVerilog (SystemVerilogState)
import           Clash.Backend.VHDL (VHDLState)
import           Clash.Backend.Verilog (VerilogState)
import qualified Clash.Driver
import           Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..))

import           Clash.GHC.PartialEval
import           Clash.GHC.Evaluator
import           Clash.GHC.GenerateBindings
import           Clash.GHC.NetlistTypes
import           Clash.GHCi.Common
import           Clash.Util (clashLibVersion, reportTimeDiff)
import qualified Data.Time.Clock as Clock
import qualified Paths_clash_ghc

-----------------------------------------------------------------------------

data GhciSettings = GhciSettings {
        GhciSettings -> [Command]
availableCommands :: [Command],
        GhciSettings -> String
shortHelpText     :: String,
        GhciSettings -> String
fullHelpText      :: String,
        GhciSettings -> PromptFunction
defPrompt         :: PromptFunction,
        GhciSettings -> PromptFunction
defPromptCont     :: PromptFunction
    }

defaultGhciSettings :: IORef ClashOpts -> GhciSettings
defaultGhciSettings :: IORef ClashOpts -> GhciSettings
defaultGhciSettings IORef ClashOpts
opts =
    GhciSettings :: [Command]
-> String
-> String
-> PromptFunction
-> PromptFunction
-> GhciSettings
GhciSettings {
        availableCommands :: [Command]
availableCommands = IORef ClashOpts -> [Command]
ghciCommands IORef ClashOpts
opts,
        shortHelpText :: String
shortHelpText     = String
defShortHelpText,
        defPrompt :: PromptFunction
defPrompt         = PromptFunction
default_prompt,
        defPromptCont :: PromptFunction
defPromptCont     = PromptFunction
default_prompt_cont,
        fullHelpText :: String
fullHelpText      = String
defFullHelpText
    }

ghciWelcomeMsg :: String
ghciWelcomeMsg :: String
ghciWelcomeMsg = String
"Clashi, version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
Data.Version.showVersion Version
Paths_clash_ghc.version String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
" (using clash-lib, version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
Data.Version.showVersion Version
clashLibVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"):\nhttps://clash-lang.org/  :? for help"

ghciCommands :: IORef ClashOpts -> [Command]
ghciCommands :: IORef ClashOpts -> [Command]
ghciCommands IORef ClashOpts
opts = ((String, String -> InputT GHCi Bool, CompletionFunc GHCi)
 -> Command)
-> [(String, String -> InputT GHCi Bool, CompletionFunc GHCi)]
-> [Command]
forall a b. (a -> b) -> [a] -> [b]
map (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
-> Command
mkCmd [
  -- Hugs users are accustomed to :e, so make sure it doesn't overlap
  (String
"?",         (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
help,                 CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"add",       ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths [String] -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
addModule,       CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"abandon",   (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
abandonCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"break",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
breakCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"back",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
backCmd,              CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"browse",    (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
browseCmd Bool
False),   CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule),
  (String
"browse!",   (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
browseCmd Bool
True),    CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule),
  (String
"cd",        (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
changeDirectory,     CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"check",     (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
checkModule,         CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModule),
  (String
"continue",  (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
continueCmd,          CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"cmd",       (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
cmdCmd,               CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"ctags",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
createCTagsWithLineNumbersCmd, CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"ctags!",    (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
createCTagsWithRegExesCmd, CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"def",       (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing (Bool -> String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => Bool -> String -> m ()
defineMacro Bool
False),  CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"def!",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing (Bool -> String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => Bool -> String -> m ()
defineMacro Bool
True),   CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"delete",    (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
deleteCmd,            CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"disable",   (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
disableCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"doc",       (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
docCmd,              CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"edit",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
editFile,            CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"enable",    (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
enableCmd,            CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"etags",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
createETagsFileCmd,   CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"force",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
forceCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"forward",   (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
forwardCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"help",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
help,                 CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"history",   (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
historyCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"info",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
info Bool
False),        CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"info!",     (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
info Bool
True),         CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"issafe",    (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
isSafeCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule),
  (String
"kind",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
kindOfType Bool
False),  CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"kind!",     (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (Bool -> String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => Bool -> String -> m ()
kindOfType Bool
True),   CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"load",      ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths [String] -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
loadModule_,     CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModuleOrFile),
  (String
"load!",     ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths [String] -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
loadModuleDefer, CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModuleOrFile),
  (String
"list",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
listCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"module",    (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
moduleCmd,            CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeSetModule),
  (String
"main",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
runMain,              CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"print",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
printCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"quit",      String -> InputT GHCi Bool
forall (m :: Type -> Type). Monad m => String -> m Bool
quit,                           CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"reload",    (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModule,        CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"reload!",   (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModuleDefer,   CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"run",       (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
runRun,               CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"script",    (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
scriptCmd,           CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"set",       (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setCmd,               CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeSetOptions),
  (String
"seti",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setiCmd,              CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeSeti),
  (String
"show",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
showCmd,              CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeShowOptions),
  (String
"showi",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
showiCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeShowiOptions),
  (String
"sprint",    (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
sprintCmd,            CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"step",      (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepCmd,              CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"steplocal", (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepLocalCmd,         CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"stepmodule",(String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepModuleCmd,        CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier),
  (String
"type",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
typeOfExpr,          CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"trace",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
traceCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression),
  (String
"unadd",     ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths [String] -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
unAddModule,     CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename),
  (String
"undef",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
undefineMacro,        CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeMacro),
  (String
"unset",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
unsetOptions,         CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeSetOptions),
  (String
"where",     (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
forall (m :: Type -> Type). GhcMonad m => String -> m ()
whereCmd,             CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion),
  (String
"vhdl",      ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths (IORef ClashOpts -> [String] -> InputT GHCi ()
makeVHDL IORef ClashOpts
opts),        CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModuleOrFile),
  (String
"verilog",   ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths (IORef ClashOpts -> [String] -> InputT GHCi ()
makeVerilog IORef ClashOpts
opts),     CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModuleOrFile),
  (String
"systemverilog",   ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths (IORef ClashOpts -> [String] -> InputT GHCi ()
makeSystemVerilog IORef ClashOpts
opts),     CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModuleOrFile),
  (String
"instances", (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
instancesCmd,        CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression)
  ] [Command] -> [Command] -> [Command]
forall a. [a] -> [a] -> [a]
++ ((String, String -> InputT GHCi Bool) -> Command)
-> [(String, String -> InputT GHCi Bool)] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map (String, String -> InputT GHCi Bool) -> Command
mkCmdHidden [ -- hidden commands
  (String
"all-types", (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
allTypesCmd),
  (String
"complete",  (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
completeCmd),
  (String
"loc-at",    (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
locAtCmd),
  (String
"type-at",   (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
typeAtCmd),
  (String
"uses",      (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' String -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
usesCmd)
  ]
 where
  mkCmd :: (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
-> Command
mkCmd (String
n,String -> InputT GHCi Bool
a,CompletionFunc GHCi
c) = Command :: String
-> (String -> InputT GHCi Bool)
-> Bool
-> CompletionFunc GHCi
-> Command
Command { cmdName :: String
cmdName = String
n
                          , cmdAction :: String -> InputT GHCi Bool
cmdAction = String -> InputT GHCi Bool
a
                          , cmdHidden :: Bool
cmdHidden = Bool
False
                          , cmdCompletionFunc :: CompletionFunc GHCi
cmdCompletionFunc = CompletionFunc GHCi
c
                          }

  mkCmdHidden :: (String, String -> InputT GHCi Bool) -> Command
mkCmdHidden (String
n,String -> InputT GHCi Bool
a) = Command :: String
-> (String -> InputT GHCi Bool)
-> Bool
-> CompletionFunc GHCi
-> Command
Command { cmdName :: String
cmdName = String
n
                              , cmdAction :: String -> InputT GHCi Bool
cmdAction = String -> InputT GHCi Bool
a
                              , cmdHidden :: Bool
cmdHidden = Bool
True
                              , cmdCompletionFunc :: CompletionFunc GHCi
cmdCompletionFunc = CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion
                              }

-- We initialize readline (in the interactiveUI function) to use
-- word_break_chars as the default set of completion word break characters.
-- This can be overridden for a particular command (for example, filename
-- expansion shouldn't consider '/' to be a word break) by setting the third
-- entry in the Command tuple above.
--
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
word_break_chars :: String
word_break_chars :: String
word_break_chars = String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
specials String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symbols

symbols, specials, spaces :: String
symbols :: String
symbols = String
"!#$%&*+/<=>?@\\^|-~"
specials :: String
specials = String
"(),;[]`{}"
spaces :: String
spaces = String
" \t\n"

flagWordBreakChars :: String
flagWordBreakChars :: String
flagWordBreakChars = String
" \t\n"


keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
keepGoing :: (String -> GHCi ()) -> String -> InputT GHCi Bool
keepGoing String -> GHCi ()
a String
str = (String -> InputT GHCi ()) -> String -> InputT GHCi Bool
forall (m :: Type -> Type).
Monad m =>
(String -> m ()) -> String -> m Bool
keepGoing' (GHCi () -> InputT GHCi ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi () -> InputT GHCi ())
-> (String -> GHCi ()) -> String -> InputT GHCi ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GHCi ()
a) String
str

keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
keepGoing' :: (String -> m ()) -> String -> m Bool
keepGoing' String -> m ()
a String
str = String -> m ()
a String
str m () -> m Bool -> m Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
keepGoingPaths :: ([String] -> InputT GHCi ()) -> String -> InputT GHCi Bool
keepGoingPaths [String] -> InputT GHCi ()
a String
str
 = do case String -> Either String [String]
toArgs String
str of
          Left String
err -> IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ()) -> IO () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
          Right [String]
args -> [String] -> InputT GHCi ()
a [String]
args
      Bool -> InputT GHCi Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

defShortHelpText :: String
defShortHelpText :: String
defShortHelpText = String
"use :? for help.\n"

defFullHelpText :: String
defFullHelpText :: String
defFullHelpText =
  String
" Commands available from the prompt:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   <statement>                 evaluate/run <statement>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :                           repeat last command\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :{\\n ..lines.. \\n:}\\n       multiline command\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :add [*]<module> ...        add module(s) to the current target set\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: more details; *: all top-level names)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :cd <dir>                   change directory to <dir>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :cmd <expr>                 run the commands returned by <expr>::IO String\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :complete <dom> [<rng>] <s> list completions for partial input string\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: use regex instead of line number)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :def[!] <cmd> <expr>        define command :<cmd> (later defined command has\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               precedence, ::<cmd> is always a builtin command)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: redefine an existing command name)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :doc <name>                 display docs for the given name (experimental)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :edit <file>                edit file\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :edit                       edit last module\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :help, :?                   display this list of commands\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :info[!] [<name> ...]       display information about the given names\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: do not filter instances)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :instances <type>           display the class instances available for <type>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :issafe [<mod>]             display safe haskell information of module <mod>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :kind[!] <type>             show the kind of <type>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: also print the normalised type)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :load[!] [*]<module> ...    load module(s) and their dependents\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: defer type errors)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :main [<arguments> ...]     run the main function with the given arguments\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :quit                       exit GHCi\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :reload[!]                  reload the current module set\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (!: defer type errors)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :run function [<arguments> ...] run the function with the given arguments\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :script <file>              run the script <file>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :type <expr>                show the type of <expr>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :type +d <expr>             show the type of <expr>, defaulting type variables\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :unadd <module> ...         remove module(s) from the current target set\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :undef <cmd>                undefine user-defined command :<cmd>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   ::<cmd>                     run the builtin command\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :!<command>                 run the shell command <command>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :vhdl                       synthesize currently loaded module to vhdl\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :vhdl [<module>]            synthesize specified modules/files to vhdl\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :verilog                    synthesize currently loaded module to verilog\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :verilog [<module>]         synthesize specified modules/files to verilog\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :systemverilog              synthesize currently loaded module to systemverilog\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :systemverilog [<module>]   synthesize specified modules/files to systemverilog\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
" -- Commands for debugging:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :abandon                    at a breakpoint, abandon current computation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :back [<n>]                 go back in the history N steps (after :trace)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :break <name>               set a breakpoint on the specified function\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :continue                   resume after a breakpoint\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :delete <number> ...        delete the specified breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :delete *                   delete all breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :disable <number> ...       disable the specified breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :disable *                  disable all breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :enable <number> ...        enable the specified breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :enable *                   enable all breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :force <expr>               print <expr>, forcing unevaluated parts\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :forward [<n>]              go forward in the history N step s(after :back)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :history [<n>]              after :trace, show the execution history\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :list                       show the source code around current breakpoint\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :list <identifier>          show the source code for <identifier>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :list [<module>] <line>     show the source code around line number <line>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :print [<name> ...]         show a value without forcing its computation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :sprint [<name> ...]        simplified version of :print\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :step                       single-step after stopping at a breakpoint\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :step <expr>                single-step into <expr>\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :steplocal                  single-step within the current top-level binding\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :stepmodule                 single-step restricted to the current module\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :trace                      trace after stopping at a breakpoint\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++

  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
" -- Commands for changing settings:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set <option> ...           set options\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :seti <option> ...          set options for interactive evaluation only\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set local-config { source | ignore }\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               set whether to source .clashi in current dir\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               (loading untrusted config is a security issue)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set args <arg> ...         set the arguments returned by System.getArgs\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set prog <progname>        set the value returned by System.getProgName\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set prompt <prompt>        set the prompt used in GHCi\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set prompt-function <expr> set the function to handle the prompt\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set prompt-cont-function <expr>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                               set the function to handle the continuation prompt\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set editor <cmd>           set the command used for :edit\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :unset <option> ...         unset options\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"  Options for ':set' and ':unset':\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    +m            allow multiline commands\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    +r            revert top-level expressions after each evaluation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    +s            print timing/memory stats after each evaluation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    +t            print type after evaluation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    +c            collect type/location info after loading modules\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"    -<flags>      most GHC command line flags can also be set here\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                         (eg. -v2, -XFlexibleInstances, etc.)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                    for GHCi-specific flags, see User's Guide,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                    Flag reference, Interactive-mode options\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
" -- Commands for displaying information:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show bindings              show the current bindings made at the prompt\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show breaks                show the active breakpoints\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show context               show the breakpoint context\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show imports               show the current imports\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show linker                show current linker state\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show modules               show the currently loaded modules\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show packages              show the currently active package flags\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show paths                 show the currently active search paths\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show language              show the currently active language flags\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show targets               show the current set of targets\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :show <setting>             show value of <setting>, which is one of\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"                                  [args, prog, editor, stop]\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"   :showi language             show language flags for interactive evaluation\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n"

findEditor :: IO String
findEditor :: IO String
findEditor = do
  String -> IO String
getEnv String
"EDITOR"
    IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> do
#if defined(mingw32_HOST_OS)
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
#else
        String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
""
#endif

default_progname, default_stop :: String
default_progname :: String
default_progname = String
"<interactive>"
default_stop :: String
default_stop = String
""

default_prompt, default_prompt_cont :: PromptFunction
default_prompt :: PromptFunction
default_prompt = String -> PromptFunction
generatePromptFunctionFromString String
"%s> "
default_prompt_cont :: PromptFunction
default_prompt_cont = String -> PromptFunction
generatePromptFunctionFromString String
"%s| "

default_args :: [String]
default_args :: [String]
default_args = []

interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
interactiveUI :: GhciSettings -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
interactiveUI GhciSettings
config [(String, Maybe Phase)]
srcs Maybe [String]
maybe_exprs = do
   -- HACK! If we happen to get into an infinite loop (eg the user
   -- types 'let x=x in x' at the prompt), then the thread will block
   -- on a blackhole, and become unreachable during GC.  The GC will
   -- detect that it is unreachable and send it the NonTermination
   -- exception.  However, since the thread is unreachable, everything
   -- it refers to might be finalized, including the standard Handles.
   -- This sounds like a bug, but we don't have a good solution right
   -- now.
   StablePtr Handle
_ <- IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (StablePtr Handle) -> Ghc (StablePtr Handle))
-> IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (StablePtr Handle)
forall a. a -> IO (StablePtr a)
newStablePtr Handle
stdin
   StablePtr Handle
_ <- IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (StablePtr Handle) -> Ghc (StablePtr Handle))
-> IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (StablePtr Handle)
forall a. a -> IO (StablePtr a)
newStablePtr Handle
stdout
   StablePtr Handle
_ <- IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (StablePtr Handle) -> Ghc (StablePtr Handle))
-> IO (StablePtr Handle) -> Ghc (StablePtr Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (StablePtr Handle)
forall a. a -> IO (StablePtr a)
newStablePtr Handle
stderr

    -- Initialise buffering for the *interpreted* I/O system
   (ForeignHValue
nobuffering, ForeignHValue
flush) <- Ghc (ForeignHValue, ForeignHValue)
initInterpBuffering

   -- The initial set of DynFlags used for interactive evaluation is the same
   -- as the global DynFlags, plus -XExtendedDefaultRules and
   -- -XNoMonomorphismRestriction.
   -- See note [Changing language extensions for interactive evaluation] #10857
   DynFlags
dflags <- Ghc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
   let dflags' :: DynFlags
dflags' = (Extension
-> (DynFlags -> Extension -> DynFlags) -> DynFlags -> DynFlags
xopt_set_unlessExplSpec
                      Extension
LangExt.ExtendedDefaultRules DynFlags -> Extension -> DynFlags
xopt_set)
               (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extension
-> (DynFlags -> Extension -> DynFlags) -> DynFlags -> DynFlags
xopt_set_unlessExplSpec
                      Extension
LangExt.MonomorphismRestriction DynFlags -> Extension -> DynFlags
xopt_unset)
               (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags
   DynFlags -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
dflags'

   IORef [(FastString, Int)]
lastErrLocationsRef <- IO (IORef [(FastString, Int)]) -> Ghc (IORef [(FastString, Int)])
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [(FastString, Int)]) -> Ghc (IORef [(FastString, Int)]))
-> IO (IORef [(FastString, Int)])
-> Ghc (IORef [(FastString, Int)])
forall a b. (a -> b) -> a -> b
$ [(FastString, Int)] -> IO (IORef [(FastString, Int)])
forall a. a -> IO (IORef a)
newIORef []
   DynFlags
progDynFlags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getProgramDynFlags
   [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setProgramDynFlags (DynFlags -> Ghc [InstalledUnitId])
-> DynFlags -> Ghc [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$
      -- Ensure we don't override the user's log action lest we break
      -- -ddump-json (#14078)
      DynFlags
progDynFlags { log_action :: LogAction
log_action = LogAction -> IORef [(FastString, Int)] -> LogAction
ghciLogAction (DynFlags -> LogAction
log_action DynFlags
progDynFlags)
                                                IORef [(FastString, Int)]
lastErrLocationsRef }

   Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe [String] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [String]
maybe_exprs) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
        ForeignHValue -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => ForeignHValue -> m ()
turnOffBuffering_ ForeignHValue
nobuffering
        -- Turn buffering off for GHCi's stdout
        IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout
        IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
        IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
NoBuffering
#if defined(mingw32_HOST_OS)
        -- On Unix, stdin will use the locale encoding.  The IO library
        -- doesn't do this on Windows (yet), so for now we use UTF-8,
        -- for consistency with GHC 6.10 and to make the tests work.
        liftIO $ hSetEncoding stdin utf8
#endif

   String
default_editor <- IO String -> Ghc String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> Ghc String) -> IO String -> Ghc String
forall a b. (a -> b) -> a -> b
$ IO String
findEditor
   ForeignHValue
eval_wrapper <- String -> [String] -> Ghc ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
String -> [String] -> m ForeignHValue
mkEvalWrapper String
default_progname [String]
default_args
   let prelude_import :: ImportDecl (GhcPass p)
prelude_import = ModuleName -> ImportDecl (GhcPass p)
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl ModuleName
preludeModuleName
   GHCi () -> GHCiState -> Ghc ()
forall a. GHCi a -> GHCiState -> Ghc a
startGHCi ([(String, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi [(String, Maybe Phase)]
srcs Maybe [String]
maybe_exprs)
        GHCiState :: String
-> [String]
-> ForeignHValue
-> PromptFunction
-> PromptFunction
-> String
-> String
-> LocalConfigBehaviour
-> [GHCiOption]
-> Int
-> Int
-> IntMap BreakLocation
-> ModuleEnv TickArray
-> [Command]
-> [Command]
-> Maybe Command
-> (InputT GHCi CommandResult -> InputT GHCi (Maybe Bool))
-> [String]
-> [InteractiveImport]
-> [InteractiveImport]
-> [ImportDecl GhcPs]
-> [ImportDecl GhcPs]
-> Bool
-> String
-> String
-> IORef [(FastString, Int)]
-> Map ModuleName ModInfo
-> ForeignHValue
-> ForeignHValue
-> GHCiState
GHCiState{ progname :: String
progname           = String
default_progname,
                   args :: [String]
args               = [String]
default_args,
                   evalWrapper :: ForeignHValue
evalWrapper        = ForeignHValue
eval_wrapper,
                   prompt :: PromptFunction
prompt             = GhciSettings -> PromptFunction
defPrompt GhciSettings
config,
                   prompt_cont :: PromptFunction
prompt_cont        = GhciSettings -> PromptFunction
defPromptCont GhciSettings
config,
                   stop :: String
stop               = String
default_stop,
                   editor :: String
editor             = String
default_editor,
                   options :: [GHCiOption]
options            = [],
                   localConfig :: LocalConfigBehaviour
localConfig        = LocalConfigBehaviour
SourceLocalConfig,
                   -- We initialize line number as 0, not 1, because we use
                   -- current line number while reporting errors which is
                   -- incremented after reading a line.
                   line_number :: Int
line_number        = Int
0,
                   break_ctr :: Int
break_ctr          = Int
0,
                   breaks :: IntMap BreakLocation
breaks             = IntMap BreakLocation
forall a. IntMap a
IntMap.empty,
                   tickarrays :: ModuleEnv TickArray
tickarrays         = ModuleEnv TickArray
forall a. ModuleEnv a
emptyModuleEnv,
                   ghci_commands :: [Command]
ghci_commands      = GhciSettings -> [Command]
availableCommands GhciSettings
config,
                   ghci_macros :: [Command]
ghci_macros        = [],
                   last_command :: Maybe Command
last_command       = Maybe Command
forall a. Maybe a
Nothing,
                   cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool)
cmd_wrapper        = (CommandResult -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type).
MonadThrow m =>
CommandResult -> m (Maybe Bool)
cmdSuccess (CommandResult -> InputT GHCi (Maybe Bool))
-> InputT GHCi CommandResult -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<),
                   cmdqueue :: [String]
cmdqueue           = [],
                   remembered_ctx :: [InteractiveImport]
remembered_ctx     = [],
                   transient_ctx :: [InteractiveImport]
transient_ctx      = [],
                   extra_imports :: [ImportDecl GhcPs]
extra_imports      = [],
                   prelude_imports :: [ImportDecl GhcPs]
prelude_imports    = [ImportDecl GhcPs
forall (p :: Pass). ImportDecl (GhcPass p)
prelude_import],
                   ghc_e :: Bool
ghc_e              = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [String]
maybe_exprs,
                   short_help :: String
short_help         = GhciSettings -> String
shortHelpText GhciSettings
config,
                   long_help :: String
long_help          = GhciSettings -> String
fullHelpText GhciSettings
config,
                   lastErrorLocations :: IORef [(FastString, Int)]
lastErrorLocations = IORef [(FastString, Int)]
lastErrLocationsRef,
                   mod_infos :: Map ModuleName ModInfo
mod_infos          = Map ModuleName ModInfo
forall k a. Map k a
M.empty,
                   flushStdHandles :: ForeignHValue
flushStdHandles    = ForeignHValue
flush,
                   noBuffering :: ForeignHValue
noBuffering        = ForeignHValue
nobuffering
                 }

   () -> Ghc ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

{-
Note [Changing language extensions for interactive evaluation]
--------------------------------------------------------------
GHCi maintains two sets of options:

- The "loading options" apply when loading modules
- The "interactive options" apply when evaluating expressions and commands
    typed at the GHCi prompt.

The loading options are mostly created in ghc/Main.hs:main' from the command
line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
are copied to the interactive options.

These interactive options (but not the loading options!) are supplemented
unconditionally by setting ExtendedDefaultRules ON and
MonomorphismRestriction OFF. The unconditional setting of these options
eventually overwrite settings already specified at the command line.

Therefore instead of unconditionally setting ExtendedDefaultRules and
NoMonomorphismRestriction for the interactive options, we use the function
'xopt_set_unlessExplSpec' to first check whether the extension has already
specified at the command line.

The ghci config file has not yet been processed.
-}

resetLastErrorLocations :: GhciMonad m => m ()
resetLastErrorLocations :: m ()
resetLastErrorLocations = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(FastString, Int)] -> [(FastString, Int)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GHCiState -> IORef [(FastString, Int)]
lastErrorLocations GHCiState
st) []

ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction
ghciLogAction LogAction
old_log_action IORef [(FastString, Int)]
lastErrLocations
              DynFlags
dflags WarnReason
flag Severity
severity SrcSpan
srcSpan PprStyle
style MsgDoc
msg = do
    LogAction
old_log_action DynFlags
dflags WarnReason
flag Severity
severity SrcSpan
srcSpan PprStyle
style MsgDoc
msg
    case Severity
severity of
        Severity
SevError -> case SrcSpan
srcSpan of
            RealSrcSpan RealSrcSpan
rsp -> IORef [(FastString, Int)]
-> ([(FastString, Int)] -> [(FastString, Int)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(FastString, Int)]
lastErrLocations
                ([(FastString, Int)] -> [(FastString, Int)] -> [(FastString, Int)]
forall a. [a] -> [a] -> [a]
++ [(RealSrcLoc -> FastString
srcLocFile (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
rsp), RealSrcLoc -> Int
srcLocLine (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
rsp))])
            SrcSpan
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        Severity
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData :: (String -> IO a) -> IO a -> IO a
withGhcAppData String -> IO a
right IO a
left = do
    Either IOException String
either_dir <- IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IO String
getAppUserDataDirectory String
"clash")
    case Either IOException String
either_dir of
        Right String
dir ->
            do Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
dir IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
               String -> IO a
right String
dir
        Either IOException String
_ -> IO a
left

runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi :: [(String, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi [(String, Maybe Phase)]
paths Maybe [String]
maybe_exprs = do
  DynFlags
dflags <- GHCi DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  let
   ignore_dot_ghci :: Bool
ignore_dot_ghci = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreDotGhci DynFlags
dflags

   app_user_dir :: GHCi (Maybe String)
app_user_dir = IO (Maybe String) -> GHCi (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> GHCi (Maybe String))
-> IO (Maybe String) -> GHCi (Maybe String)
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a. (String -> IO a) -> IO a -> IO a
withGhcAppData
                    (\String
dir -> Maybe String -> IO (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
dir String -> String -> String
</> String
"clashi.conf")))
                    (Maybe String -> IO (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)

   home_dir :: GHCi (Maybe String)
home_dir = do
    Either IOException String
either_dir <- IO (Either IOException String) -> GHCi (Either IOException String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException String)
 -> GHCi (Either IOException String))
-> IO (Either IOException String)
-> GHCi (Either IOException String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IO String
getEnv String
"HOME")
    case Either IOException String
either_dir of
      Right String
home -> Maybe String -> GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
home String -> String -> String
</> String
".clashi"))
      Either IOException String
_ -> Maybe String -> GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
   canonicalizePath' :: String -> IO (Maybe String)
canonicalizePath' String
fp = (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (String -> IO String
canonicalizePath String
fp)
                IO (Maybe String)
-> (IOException -> IO (Maybe String)) -> IO (Maybe String)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> Maybe String -> IO (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile :: String -> GHCi ()
sourceConfigFile String
file = do
     Bool
exists <- IO Bool -> GHCi Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> GHCi Bool) -> IO Bool -> GHCi Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
     Bool -> GHCi () -> GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
exists (GHCi () -> GHCi ()) -> GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ do
       Either IOException Handle
either_hdl <- IO (Either IOException Handle) -> GHCi (Either IOException Handle)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Handle)
 -> GHCi (Either IOException Handle))
-> IO (Either IOException Handle)
-> GHCi (Either IOException Handle)
forall a b. (a -> b) -> a -> b
$ IO Handle -> IO (Either IOException Handle)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IOMode -> IO Handle
openFile String
file IOMode
ReadMode)
       case Either IOException Handle
either_hdl of
         Left IOException
_e   -> () -> GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
         -- NOTE: this assumes that runInputT won't affect the terminal;
         -- can we assume this will always be the case?
         -- This would be a good place for runFileInputT.
         Right Handle
hdl ->
             do Prefs -> Settings GHCi -> InputT GHCi () -> GHCi ()
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs Prefs
defaultPrefs Settings GHCi
forall (m :: Type -> Type). MonadIO m => Settings m
defaultSettings (InputT GHCi () -> GHCi ()) -> InputT GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$
                          InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands (InputT GHCi (Maybe String) -> InputT GHCi ())
-> InputT GHCi (Maybe String) -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe String)
fileLoop Handle
hdl
                IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
hClose Handle
hdl IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
                -- Don't print a message if this is really ghc -e (#11478).
                -- Also, let the user silence the message with -v0
                -- (the default verbosity in GHCi is 1).
                Bool -> GHCi () -> GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe [String] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [String]
maybe_exprs Bool -> Bool -> Bool
&& DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (GHCi () -> GHCi ()) -> GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$
                  IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> GHCi ()) -> IO () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Loaded Clashi configuration from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file)

  --

  GHCi ()
forall (m :: Type -> Type). GhciMonad m => m ()
setGHCContextFromGHCiState

  [String]
processedCfgs <- if Bool
ignore_dot_ghci
    then [String] -> GHCi [String]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
    else do
      [String]
userCfgs <- do
        [String]
paths <- [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String])
-> GHCi [Maybe String] -> GHCi [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [GHCi (Maybe String)] -> GHCi [Maybe String]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ GHCi (Maybe String)
app_user_dir, GHCi (Maybe String)
home_dir ]
        [String]
checkedPaths <- IO [String] -> GHCi [String]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> GHCi [String]) -> IO [String] -> GHCi [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
checkFileAndDirPerms [String]
paths
        IO [String] -> GHCi [String]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> GHCi [String])
-> (IO [Maybe String] -> IO [String])
-> IO [Maybe String]
-> GHCi [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes) (IO [Maybe String] -> GHCi [String])
-> IO [Maybe String] -> GHCi [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
canonicalizePath' [String]
checkedPaths

      Maybe String
localCfg <- do
        let path :: String
path = String
".clashi"
        Bool
ok <- IO Bool -> GHCi Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> GHCi Bool) -> IO Bool -> GHCi Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
checkFileAndDirPerms String
path
        if Bool
ok then IO (Maybe String) -> GHCi (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> GHCi (Maybe String))
-> IO (Maybe String) -> GHCi (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
canonicalizePath' String
path else Maybe String -> GHCi (Maybe String)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

      (String -> GHCi ()) -> [String] -> GHCi ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> GHCi ()
sourceConfigFile [String]
userCfgs
        -- Process the global and user .clashi
        -- (but not $CWD/.clashi or CLI args, yet)

      LocalConfigBehaviour
behaviour <- GHCiState -> LocalConfigBehaviour
localConfig (GHCiState -> LocalConfigBehaviour)
-> GHCi GHCiState -> GHCi LocalConfigBehaviour
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState

      Maybe String
processedLocalCfg <- case Maybe String
localCfg of
        Just String
path | String
path String -> [String] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [String]
userCfgs ->
          -- don't read .clashi twice if CWD is $HOME
          case LocalConfigBehaviour
behaviour of
            LocalConfigBehaviour
SourceLocalConfig -> Maybe String
localCfg Maybe String -> GHCi () -> GHCi (Maybe String)
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ String -> GHCi ()
sourceConfigFile String
path
            LocalConfigBehaviour
IgnoreLocalConfig -> Maybe String -> GHCi (Maybe String)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        Maybe String
_ -> Maybe String -> GHCi (Maybe String)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

      [String] -> GHCi [String]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([String] -> GHCi [String]) -> [String] -> GHCi [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String])
-> (String -> [String] -> [String])
-> Maybe String
-> [String]
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String] -> [String]
forall a. a -> a
id (:) Maybe String
processedLocalCfg [String]
userCfgs

  let arg_cfgs :: [String]
arg_cfgs = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
ghciScripts DynFlags
dflags
    -- -ghci-script are collected in reverse order
    -- We don't require that a script explicitly added by -ghci-script
    -- is owned by the current user. (#6017)

  (String -> GHCi ()) -> [String] -> GHCi ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> GHCi ()
sourceConfigFile ([String] -> GHCi ()) -> [String] -> GHCi ()
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
arg_cfgs [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
processedCfgs
    -- Dedup, and remove any configs we already processed.
    -- Importantly, if $PWD/.clashi was ignored due to configuration,
    -- explicitly specifying it does cause it to be processed.

  -- Perform a :load for files given on the GHCi command line
  -- When in -e mode, if the load fails then we want to stop
  -- immediately rather than going on to evaluate the expression.
  Bool -> GHCi () -> GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([(String, Maybe Phase)] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
paths)) (GHCi () -> GHCi ()) -> GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ do
     SuccessFlag
ok <- (SomeException -> GHCi SuccessFlag)
-> GHCi SuccessFlag -> GHCi SuccessFlag
forall (m :: Type -> Type) a.
(HasDynFlags m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle (\SomeException
e -> do SomeException -> GHCi ()
forall (m :: Type -> Type). MonadIO m => SomeException -> m ()
showException SomeException
e; SuccessFlag -> GHCi SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
Failed) (GHCi SuccessFlag -> GHCi SuccessFlag)
-> GHCi SuccessFlag -> GHCi SuccessFlag
forall a b. (a -> b) -> a -> b
$
                -- TODO: this is a hack.
                Prefs
-> Settings GHCi -> InputT GHCi SuccessFlag -> GHCi SuccessFlag
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs Prefs
defaultPrefs Settings GHCi
forall (m :: Type -> Type). MonadIO m => Settings m
defaultSettings (InputT GHCi SuccessFlag -> GHCi SuccessFlag)
-> InputT GHCi SuccessFlag -> GHCi SuccessFlag
forall a b. (a -> b) -> a -> b
$
                    [(String, Maybe Phase)] -> InputT GHCi SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[(String, Maybe Phase)] -> m SuccessFlag
loadModule [(String, Maybe Phase)]
paths
     Bool -> GHCi () -> GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [String]
maybe_exprs Bool -> Bool -> Bool
&& SuccessFlag -> Bool
failed SuccessFlag
ok) (GHCi () -> GHCi ()) -> GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$
        IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))

  Maybe String -> Bool -> GHCi ()
forall (m :: Type -> Type).
GhcMonad m =>
Maybe String -> Bool -> m ()
installInteractivePrint (DynFlags -> Maybe String
interactivePrint DynFlags
dflags) (Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [String]
maybe_exprs)

  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
  Bool
is_tty <- IO Bool -> GHCi Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO Bool
hIsTerminalDevice Handle
stdin)
  let show_prompt :: Bool
show_prompt = DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
is_tty

  -- reset line number
  (GHCiState -> GHCiState) -> GHCi ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> GHCi ())
-> (GHCiState -> GHCiState) -> GHCi ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st -> GHCiState
st{line_number :: Int
line_number=Int
0}

  case Maybe [String]
maybe_exprs of
        Maybe [String]
Nothing ->
          do
            -- Set different defaulting rules (See #280)
            [String] -> GHCi ()
runGHCiExpressions
              [String
"default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]

            -- enter the interactive loop
            InputT GHCi () -> GHCi ()
forall a. InputT GHCi a -> GHCi a
runGHCiInput (InputT GHCi () -> GHCi ()) -> InputT GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands (InputT GHCi (Maybe String) -> InputT GHCi ())
-> InputT GHCi (Maybe String) -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine Bool
show_prompt Bool
is_tty
        Just [String]
exprs -> do
            -- just evaluate the expression we were given
            [String] -> GHCi ()
runGHCiExpressions [String]
exprs

  -- and finally, exit
  IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> GHCi ()) -> IO () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Leaving Clashi."

runGHCiExpressions :: [String] -> GHCi ()
runGHCiExpressions :: [String] -> GHCi ()
runGHCiExpressions [String]
exprs = do
    [String] -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [String]
exprs
    let hdle :: SomeException -> m b
hdle SomeException
e = do GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
                    -- flush the interpreter's stdout/stderr on exit (#3890)
                    m ()
forall (m :: Type -> Type). GhciMonad m => m ()
flushInterpBuffers
                    -- Jump through some hoops to get the
                    -- current progname in the exception text:
                    -- <progname>: <exception>
                    IO b -> m b
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ String -> IO b -> IO b
forall a. String -> IO a -> IO a
withProgName (GHCiState -> String
progname GHCiState
st)
                           (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ SomeException -> IO b
forall a. SomeException -> IO a
topHandler SomeException
e
                           -- this used to be topHandlerFastExit, see #2228
    Prefs -> Settings GHCi -> InputT GHCi () -> GHCi ()
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs Prefs
defaultPrefs Settings GHCi
forall (m :: Type -> Type). MonadIO m => Settings m
defaultSettings (InputT GHCi () -> GHCi ()) -> InputT GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ do
        -- make `ghc -e` exit nonzero on invalid input, see #7962
        Maybe Bool
_ <- (SomeException -> GHCi Bool)
-> Maybe (GHCi ())
-> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe Bool)
runCommands' SomeException -> GHCi Bool
forall (m :: Type -> Type) b. GhciMonad m => SomeException -> m b
hdle
             (GHCi () -> Maybe (GHCi ())
forall a. a -> Maybe a
Just (GHCi () -> Maybe (GHCi ())) -> GHCi () -> Maybe (GHCi ())
forall a b. (a -> b) -> a -> b
$ SomeException -> GHCi Any
forall (m :: Type -> Type) b. GhciMonad m => SomeException -> m b
hdle (ExitCode -> SomeException
forall e. Exception e => e -> SomeException
toException (ExitCode -> SomeException) -> ExitCode -> SomeException
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1) GHCi Any -> GHCi () -> GHCi ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
             (Maybe String -> InputT GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
        () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput InputT GHCi a
f = do
    DynFlags
dflags <- GHCi DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    let ghciHistory :: Bool
ghciHistory = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciHistory DynFlags
dflags
    let localGhciHistory :: Bool
localGhciHistory = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LocalGhciHistory DynFlags
dflags
    String
currentDirectory <- IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory

    Maybe String
histFile <- case (Bool
ghciHistory, Bool
localGhciHistory) of
      (Bool
True, Bool
True) -> Maybe String -> GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
currentDirectory String -> String -> String
</> String
".clashi_history"))
      (Bool
True, Bool
_) -> IO (Maybe String) -> GHCi (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> GHCi (Maybe String))
-> IO (Maybe String) -> GHCi (Maybe String)
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a. (String -> IO a) -> IO a -> IO a
withGhcAppData
        (\String
dir -> Maybe String -> IO (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
dir String -> String -> String
</> String
"clashi_history"))) (Maybe String -> IO (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
      (Bool, Bool)
_ -> Maybe String -> GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

    Settings GHCi -> InputT GHCi a -> GHCi a
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT
        (CompletionFunc GHCi -> Settings GHCi -> Settings GHCi
forall (m :: Type -> Type).
CompletionFunc m -> Settings m -> Settings m
setComplete CompletionFunc GHCi
ghciCompleteWord (Settings GHCi -> Settings GHCi) -> Settings GHCi -> Settings GHCi
forall a b. (a -> b) -> a -> b
$ Settings GHCi
forall (m :: Type -> Type). MonadIO m => Settings m
defaultSettings {historyFile :: Maybe String
historyFile = Maybe String
histFile})
        InputT GHCi a
f

-- | How to get the next input line from the user
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine Bool
show_prompt Bool
is_tty
  | Bool
is_tty = do
    String
prmpt <- if Bool
show_prompt then GHCi String -> InputT GHCi String
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi String
mkPrompt else String -> InputT GHCi String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
""
    Maybe String
r <- String -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prmpt
    InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => m ()
incrementLineNo
    Maybe String -> InputT GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
r
  | Bool
otherwise = do
    Bool -> InputT GHCi () -> InputT GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
show_prompt (InputT GHCi () -> InputT GHCi ())
-> InputT GHCi () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ GHCi String -> InputT GHCi String
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi String
mkPrompt InputT GHCi String -> (String -> InputT GHCi ()) -> InputT GHCi ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ())
-> (String -> IO ()) -> String -> InputT GHCi ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr
    Handle -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe String)
fileLoop Handle
stdin

-- NOTE: We only read .clashi files if they are owned by the current user,
-- and aren't world writable (files owned by root are ok, see #9324).
-- Otherwise, we could be accidentally running code planted by
-- a malicious third party.

-- Furthermore, We only read ./.clashi if . is owned by the current user
-- and isn't writable by anyone else.  I think this is sufficient: we
-- don't need to check .. and ../.. etc. because "."  always refers to
-- the same directory while a process is running.

checkFileAndDirPerms :: FilePath -> IO Bool
checkFileAndDirPerms :: String -> IO Bool
checkFileAndDirPerms String
file = do
  Bool
file_ok <- String -> IO Bool
checkPerms String
file
  -- Do not check dir perms when .clashi doesn't exist, otherwise GHCi will
  -- print some confusing and useless warnings in some cases (e.g. in
  -- travis). Note that we can't add a test for this, as all ghci tests should
  -- run with -ignore-dot-ghci, which means we never get here.
  if Bool
file_ok then String -> IO Bool
checkPerms (String -> String
getDirectory String
file) else Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
  where
  getDirectory :: String -> String
getDirectory String
f = case String -> String
takeDirectory String
f of
    String
"" -> String
"."
    String
d -> String
d

checkPerms :: FilePath -> IO Bool
#if defined(mingw32_HOST_OS)
checkPerms _ = return True
#else
checkPerms :: String -> IO Bool
checkPerms String
file =
  (IOException -> IO Bool) -> IO Bool -> IO Bool
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO (\IOException
_ -> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    FileStatus
st <- String -> IO FileStatus
getFileStatus String
file
    UserID
me <- IO UserID
getRealUserID
    let mode :: FileMode
mode = FileStatus -> FileMode
System.Posix.fileMode FileStatus
st
        ok :: Bool
ok = (FileStatus -> UserID
fileOwner FileStatus
st UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
me Bool -> Bool -> Bool
|| FileStatus -> UserID
fileOwner FileStatus
st UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
0) Bool -> Bool -> Bool
&&
             FileMode
groupWriteMode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
mode FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
groupWriteMode Bool -> Bool -> Bool
&&
             FileMode
otherWriteMode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
mode FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
otherWriteMode
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- #8248: Improving warning to include a possible fix.
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"*** WARNING: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
" is writable by someone else, IGNORING!" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"\nSuggested fix: execute 'chmod go-w " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
    Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
ok
#endif

incrementLineNo :: GhciMonad m => m ()
incrementLineNo :: m ()
incrementLineNo = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState GHCiState -> GHCiState
incLineNo
  where
    incLineNo :: GHCiState -> GHCiState
incLineNo GHCiState
st = GHCiState
st { line_number :: Int
line_number = GHCiState -> Int
line_number GHCiState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }

fileLoop :: GhciMonad m => Handle -> m (Maybe String)
fileLoop :: Handle -> m (Maybe String)
fileLoop Handle
hdl = do
   Either IOException String
l <- IO (Either IOException String) -> m (Either IOException String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException String) -> m (Either IOException String))
-> IO (Either IOException String) -> m (Either IOException String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO (IO String -> IO (Either IOException String))
-> IO String -> IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
hdl
   case Either IOException String
l of
        Left IOException
e | IOException -> Bool
isEOFError IOException
e              -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
               | -- as we share stdin with the program, the program
                 -- might have already closed it, so we might get a
                 -- handle-closed exception. We therefore catch that
                 -- too.
                 IOException -> Bool
isIllegalOperation IOException
e      -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
               | IOErrorType
InvalidArgument <- IOErrorType
etype  -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
               | Bool
otherwise                 -> IO (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ IOException -> IO (Maybe String)
forall a. IOException -> IO a
ioError IOException
e
                where etype :: IOErrorType
etype = IOException -> IOErrorType
ioeGetErrorType IOException
e
                -- treat InvalidArgument in the same way as EOF:
                -- this can happen if the user closed stdin, or
                -- perhaps did getContents which closes stdin at
                -- EOF.
        Right String
l' -> do
           m ()
forall (m :: Type -> Type). GhciMonad m => m ()
incrementLineNo
           Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
l')

formatCurrentTime :: String -> IO String
formatCurrentTime :: String -> IO String
formatCurrentTime String
format =
  IO ZonedTime
getZonedTime IO ZonedTime -> (ZonedTime -> IO String) -> IO String
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> IO String)
-> (ZonedTime -> String) -> ZonedTime -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format)

getUserName :: IO String
getUserName :: IO String
getUserName = do
#if defined(mingw32_HOST_OS)
  getEnv "USERNAME"
    `catchIO` \e -> do
      putStrLn $ show e
      return ""
#else
  IO String
getLoginName
#endif

getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
getInfoForPrompt :: m (MsgDoc, [String], Int)
getInfoForPrompt = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext

  MsgDoc
context_bit <-
        case [Resume]
resumes of
            [] -> MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return MsgDoc
empty
            Resume
r:[Resume]
_ -> do
                let ix :: Int
ix = Resume -> Int
GHC.resumeHistoryIx Resume
r
                if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                   then MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> MsgDoc
brackets (SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Resume -> SrcSpan
GHC.resumeSpan Resume
r)) MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
space)
                   else do
                        let hist :: History
hist = Resume -> [History]
GHC.resumeHistory Resume
r [History] -> Int -> History
forall a. [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                        SrcSpan
pan <- History -> m SrcSpan
forall (m :: Type -> Type). GhcMonad m => History -> m SrcSpan
GHC.getHistorySpan History
hist
                        MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> MsgDoc
brackets (Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Int -> Int
forall a. Num a => a -> a
negate Int
ix) MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
':'
                                          MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
pan) MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
space)

  let
        dots :: MsgDoc
dots | Resume
_:[Resume]
rs <- [Resume]
resumes, Bool -> Bool
not ([Resume] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Resume]
rs) = String -> MsgDoc
text String
"... "
             | Bool
otherwise = MsgDoc
empty

        rev_imports :: [InteractiveImport]
rev_imports = [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a]
reverse [InteractiveImport]
imports -- rightmost are the most recent

        myIdeclName :: ImportDecl pass -> ModuleName
myIdeclName ImportDecl pass
d | Just Located ModuleName
m <- ImportDecl pass -> Maybe (Located ModuleName)
forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclAs ImportDecl pass
d = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
m
                      | Bool
otherwise           = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl pass
d)

        modules_names :: [String]
modules_names =
             [Char
'*'Char -> String -> String
forall a. a -> [a] -> [a]
:(ModuleName -> String
moduleNameString ModuleName
m) | IIModule ModuleName
m <- [InteractiveImport]
rev_imports] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
             [ModuleName -> String
moduleNameString (ImportDecl GhcPs -> ModuleName
forall pass. ImportDecl pass -> ModuleName
myIdeclName ImportDecl GhcPs
d) | IIDecl ImportDecl GhcPs
d <- [InteractiveImport]
rev_imports]
        line :: Int
line = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ GHCiState -> Int
line_number GHCiState
st

  (MsgDoc, [String], Int) -> m (MsgDoc, [String], Int)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc
dots MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
context_bit, [String]
modules_names, Int
line)

parseCallEscape :: String -> (String, String)
parseCallEscape :: String -> (String, String)
parseCallEscape String
s
  | Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
beforeOpen) = (String
"", String
"")
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
sinceOpen               = (String
"", String
"")
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
sinceClosed             = (String
"", String
"")
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
cmd                     = (String
"", String
"")
  | Bool
otherwise                    = (String
cmd, String -> String
forall a. [a] -> [a]
tail String
sinceClosed)
  where
    (String
beforeOpen, String
sinceOpen) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'(') String
s
    (String
cmd, String
sinceClosed) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
')') (String -> String
forall a. [a] -> [a]
tail String
sinceOpen)

checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors (Char
'%':Char
'c':Char
'a':Char
'l':Char
'l':String
xs) =
  case String -> (String, String)
parseCallEscape String
xs of
    (String
"", String
"") -> String -> Maybe String
forall a. a -> Maybe a
Just (String
"Incorrect %call syntax. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"Should be %call(a command and arguments).")
    (String
_, String
afterClosed) -> String -> Maybe String
checkPromptStringForErrors String
afterClosed
checkPromptStringForErrors (Char
'%':Char
'%':String
xs) = String -> Maybe String
checkPromptStringForErrors String
xs
checkPromptStringForErrors (Char
_:String
xs) = String -> Maybe String
checkPromptStringForErrors String
xs
checkPromptStringForErrors String
"" = Maybe String
forall a. Maybe a
Nothing

generatePromptFunctionFromString :: String -> PromptFunction
generatePromptFunctionFromString :: String -> PromptFunction
generatePromptFunctionFromString String
promptS [String]
modules_names Int
line =
        String -> GHCi MsgDoc
processString String
promptS
  where
        processString :: String -> GHCi SDoc
        processString :: String -> GHCi MsgDoc
processString (Char
'%':Char
's':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) (MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return MsgDoc
modules_list) (String -> GHCi MsgDoc
processString String
xs)
            where
              modules_list :: MsgDoc
modules_list = [MsgDoc] -> MsgDoc
hsep ([MsgDoc] -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall a b. (a -> b) -> a -> b
$ (String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text [String]
modules_names
        processString (Char
'%':Char
'l':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) (MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> GHCi MsgDoc) -> MsgDoc -> GHCi MsgDoc
forall a b. (a -> b) -> a -> b
$ Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int
line) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
'%':Char
'd':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
formatted_time) (String -> GHCi MsgDoc
processString String
xs)
            where
              formatted_time :: GHCi String
formatted_time = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ String -> IO String
formatCurrentTime String
"%a %b %d"
        processString (Char
'%':Char
't':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
formatted_time) (String -> GHCi MsgDoc
processString String
xs)
            where
              formatted_time :: GHCi String
formatted_time = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ String -> IO String
formatCurrentTime String
"%H:%M:%S"
        processString (Char
'%':Char
'T':String
xs) = do
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
formatted_time) (String -> GHCi MsgDoc
processString String
xs)
            where
              formatted_time :: GHCi String
formatted_time = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ String -> IO String
formatCurrentTime String
"%I:%M:%S"
        processString (Char
'%':Char
'@':String
xs) = do
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
formatted_time) (String -> GHCi MsgDoc
processString String
xs)
            where
              formatted_time :: GHCi String
formatted_time = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ String -> IO String
formatCurrentTime String
"%I:%M %P"
        processString (Char
'%':Char
'A':String
xs) = do
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
formatted_time) (String -> GHCi MsgDoc
processString String
xs)
            where
              formatted_time :: GHCi String
formatted_time = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ String -> IO String
formatCurrentTime String
"%H:%M"
        processString (Char
'%':Char
'u':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
user_name) (String -> GHCi MsgDoc
processString String
xs)
            where
              user_name :: GHCi String
user_name = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ IO String
getUserName
        processString (Char
'%':Char
'w':String
xs) =
            (MsgDoc -> MsgDoc -> MsgDoc)
-> GHCi MsgDoc -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MsgDoc -> MsgDoc -> MsgDoc
(<>) ((String -> MsgDoc) -> GHCi String -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text GHCi String
current_directory) (String -> GHCi MsgDoc
processString String
xs)
            where
              current_directory :: GHCi String
current_directory = IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory
        processString (Char
'%':Char
'o':String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((String -> MsgDoc
text String
os) MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
'%':Char
'a':String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((String -> MsgDoc
text String
arch) MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
'%':Char
'N':String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((String -> MsgDoc
text String
compilerName) MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
'%':Char
'V':String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion Version
compilerVersion) MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
'%':Char
'c':Char
'a':Char
'l':Char
'l':String
xs) = do
            String
respond <- IO String -> GHCi String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> GHCi String) -> IO String -> GHCi String
forall a b. (a -> b) -> a -> b
$ do
                (ExitCode
code, String
out, String
err) <-
                    String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
                    ([String] -> String
forall a. [a] -> a
head [String]
list_words) ([String] -> [String]
forall a. [a] -> [a]
tail [String]
list_words) String
""
                    IO (ExitCode, String, String)
-> (IOException -> IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e -> (ExitCode, String, String) -> IO (ExitCode, String, String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, String
"", IOException -> String
forall a. Show a => a -> String
show IOException
e)
                case ExitCode
code of
                    ExitCode
ExitSuccess -> String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
out
                    ExitCode
_ -> do
                        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
                        String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
""
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((String -> MsgDoc
text String
respond) MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
afterClosed)
            where
              (String
cmd, String
afterClosed) = String -> (String, String)
parseCallEscape String
xs
              list_words :: [String]
list_words = String -> [String]
words String
cmd
        processString (Char
'%':Char
'%':String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((Char -> MsgDoc
char Char
'%') MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString (Char
x:String
xs) =
            (MsgDoc -> MsgDoc) -> GHCi MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM (Char -> MsgDoc
char Char
x MsgDoc -> MsgDoc -> MsgDoc
<>) (String -> GHCi MsgDoc
processString String
xs)
        processString String
"" =
            MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return MsgDoc
empty

mkPrompt :: GHCi String
mkPrompt :: GHCi String
mkPrompt = do
  GHCiState
st <- GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  DynFlags
dflags <- GHCi DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  (MsgDoc
context, [String]
modules_names, Int
line) <- GHCi (MsgDoc, [String], Int)
forall (m :: Type -> Type).
GhciMonad m =>
m (MsgDoc, [String], Int)
getInfoForPrompt

  MsgDoc
prompt_string <- (GHCiState -> PromptFunction
prompt GHCiState
st) [String]
modules_names Int
line
  let prompt_doc :: MsgDoc
prompt_doc = MsgDoc
context MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
prompt_string

  String -> GHCi String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags MsgDoc
prompt_doc)

queryQueue :: GhciMonad m => m (Maybe String)
queryQueue :: m (Maybe String)
queryQueue = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  case GHCiState -> [String]
cmdqueue GHCiState
st of
    []   -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    String
c:[String]
cs -> do GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{ cmdqueue :: [String]
cmdqueue = [String]
cs }
               Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
c)

-- Reconfigurable pretty-printing Ticket #5461
installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()
installInteractivePrint :: Maybe String -> Bool -> m ()
installInteractivePrint Maybe String
Nothing Bool
_  = () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
installInteractivePrint (Just String
ipFun) Bool
exprmode = do
  SuccessFlag
ok <- m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
m SuccessFlag -> m SuccessFlag
trySuccess (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
                [Name]
names <- String -> m [Name]
forall (m :: Type -> Type). GhcMonad m => String -> m [Name]
GHC.parseName String
ipFun
                let name :: Name
name = case [Name]
names of
                             Name
name':[Name]
_ -> Name
name'
                             [] -> String -> Name
forall a. String -> a
panic String
"installInteractivePrint"
                (HscEnv -> HscEnv) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
he -> let new_ic :: InteractiveContext
new_ic = InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName (HscEnv -> InteractiveContext
hsc_IC HscEnv
he) Name
name
                                      in HscEnv
he{hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
new_ic})
                SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
Succeeded

  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok Bool -> Bool -> Bool
&& Bool
exprmode) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))

-- | The main read-eval-print loop
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
runCommands InputT GHCi (Maybe String)
gCmd = (SomeException -> GHCi Bool)
-> Maybe (GHCi ())
-> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe Bool)
runCommands' SomeException -> GHCi Bool
forall (m :: Type -> Type). GhciMonad m => SomeException -> m Bool
handler Maybe (GHCi ())
forall a. Maybe a
Nothing InputT GHCi (Maybe String)
gCmd InputT GHCi (Maybe Bool) -> InputT GHCi () -> InputT GHCi ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
             -> Maybe (GHCi ()) -- ^ Source error handler
             -> InputT GHCi (Maybe String)
             -> InputT GHCi (Maybe Bool)
         -- We want to return () here, but have to return (Maybe Bool)
         -- because gmask is not polymorphic enough: we want to use
         -- unmask at two different types.
runCommands' :: (SomeException -> GHCi Bool)
-> Maybe (GHCi ())
-> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe Bool)
runCommands' SomeException -> GHCi Bool
eh Maybe (GHCi ())
sourceErrorHandler InputT GHCi (Maybe String)
gCmd = ((InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
 -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a b.
ExceptionMonad m =>
((m a -> m a) -> m b) -> m b
gmask (((InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
  -> InputT GHCi (Maybe Bool))
 -> InputT GHCi (Maybe Bool))
-> ((InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
    -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ \InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
unmask -> do
    Maybe Bool
b <- (SomeException -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle (\SomeException
e -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                          Just AsyncException
UserInterrupt -> Maybe Bool -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Bool -> InputT GHCi (Maybe Bool))
-> Maybe Bool -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                          Maybe AsyncException
_ -> case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                                 Just GhcException
ghce ->
                                   do IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (GhcException -> IO ()
forall a. Show a => a -> IO ()
print (GhcException
ghce :: GhcException))
                                      Maybe Bool -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
                                 Maybe GhcException
_other ->
                                   IO (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO (Maybe Bool)
forall e a. Exception e => e -> IO a
Exception.throwIO SomeException
e))
            (InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
unmask (InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ (SomeException -> GHCi Bool)
-> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
eh InputT GHCi (Maybe String)
gCmd)
    case Maybe Bool
b of
      Maybe Bool
Nothing -> Maybe Bool -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
      Just Bool
success -> do
        Bool -> InputT GHCi () -> InputT GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
success (InputT GHCi () -> InputT GHCi ())
-> InputT GHCi () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ InputT GHCi ()
-> (GHCi () -> InputT GHCi ()) -> Maybe (GHCi ()) -> InputT GHCi ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()) GHCi () -> InputT GHCi ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Maybe (GHCi ())
sourceErrorHandler
        InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
unmask (InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ (SomeException -> GHCi Bool)
-> Maybe (GHCi ())
-> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe Bool)
runCommands' SomeException -> GHCi Bool
eh Maybe (GHCi ())
sourceErrorHandler InputT GHCi (Maybe String)
gCmd

-- | Evaluate a single line of user input (either :<command> or Haskell code).
-- A result of Nothing means there was no more input to process.
-- Otherwise the result is Just b where b is True if the command succeeded;
-- this is relevant only to ghc -e, which will exit with status 1
-- if the command was unsuccessful. GHCi will continue in either case.
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
            -> InputT GHCi (Maybe Bool)
runOneCommand :: (SomeException -> GHCi Bool)
-> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
eh InputT GHCi (Maybe String)
gCmd = do
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
  Maybe String
mb_cmd0 <- InputT GHCi (Maybe String) -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
m (Maybe String) -> m (Maybe String)
noSpace (GHCi (Maybe String) -> InputT GHCi (Maybe String)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi (Maybe String)
forall (m :: Type -> Type). GhciMonad m => m (Maybe String)
queryQueue)
  Maybe String
mb_cmd1 <- InputT GHCi (Maybe String)
-> (String -> InputT GHCi (Maybe String))
-> Maybe String
-> InputT GHCi (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (InputT GHCi (Maybe String) -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
m (Maybe String) -> m (Maybe String)
noSpace InputT GHCi (Maybe String)
gCmd) (Maybe String -> InputT GHCi (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe String -> InputT GHCi (Maybe String))
-> (String -> Maybe String) -> String -> InputT GHCi (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just) Maybe String
mb_cmd0
  case Maybe String
mb_cmd1 of
    Maybe String
Nothing -> Maybe Bool -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
    Just String
c  -> do
      GHCiState
st <- InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      (SomeException -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a.
(HasDynFlags m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle (\SomeException
e -> GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
-> GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ SomeException -> GHCi Bool
eh SomeException
e GHCi Bool -> (Bool -> GHCi (Maybe Bool)) -> GHCi (Maybe Bool)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Bool -> GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Bool -> GHCi (Maybe Bool))
-> (Bool -> Maybe Bool) -> Bool -> GHCi (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Bool
forall a. a -> Maybe a
Just) (InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
        (SourceError -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type).
GhcMonad m =>
SourceError -> m (Maybe Bool)
printErrorAndFail (InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
          GHCiState -> InputT GHCi CommandResult -> InputT GHCi (Maybe Bool)
cmd_wrapper GHCiState
st (InputT GHCi CommandResult -> InputT GHCi (Maybe Bool))
-> InputT GHCi CommandResult -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ String -> InputT GHCi CommandResult
doCommand String
c
               -- source error's are handled by runStmt
               -- is the handler necessary here?
  where
    printErrorAndFail :: SourceError -> m (Maybe Bool)
printErrorAndFail SourceError
err = do
        SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
err
        Maybe Bool -> m (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Bool -> m (Maybe Bool)) -> Maybe Bool -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False     -- Exit ghc -e, but not GHCi

    noSpace :: m (Maybe String) -> m (Maybe String)
noSpace m (Maybe String)
q = m (Maybe String)
q m (Maybe String)
-> (Maybe String -> m (Maybe String)) -> m (Maybe String)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe String)
-> (String -> m (Maybe String)) -> Maybe String -> m (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
                            (\String
c -> case String -> String
removeSpaces String
c of
                                     String
""   -> m (Maybe String) -> m (Maybe String)
noSpace m (Maybe String)
q
                                     String
":{" -> m (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
m (Maybe String) -> m (Maybe String)
multiLineCmd m (Maybe String)
q
                                     String
_    -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
c) )
    multiLineCmd :: m (Maybe String) -> m (Maybe String)
multiLineCmd m (Maybe String)
q = do
      GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      let p :: PromptFunction
p = GHCiState -> PromptFunction
prompt GHCiState
st
      GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{ prompt :: PromptFunction
prompt = GHCiState -> PromptFunction
prompt_cont GHCiState
st }
      Maybe String
mb_cmd <- m (Maybe String) -> String -> m (Maybe String)
forall (m :: Type -> Type).
MonadIO m =>
m (Maybe String) -> String -> m (Maybe String)
collectCommand m (Maybe String)
q String
"" m (Maybe String) -> m () -> m (Maybe String)
forall (m :: Type -> Type) a b.
ExceptionMonad m =>
m a -> m b -> m a
`GHC.gfinally`
                (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st' -> GHCiState
st' { prompt :: PromptFunction
prompt = PromptFunction
p })
      Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
mb_cmd
    -- we can't use removeSpaces for the sublines here, so
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix),
    -- we get rid of any extra spaces for the ":}" test;
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand :: m (Maybe String) -> String -> m (Maybe String)
collectCommand m (Maybe String)
q String
c = m (Maybe String)
q m (Maybe String)
-> (Maybe String -> m (Maybe String)) -> m (Maybe String)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      m (Maybe String)
-> (String -> m (Maybe String)) -> Maybe String -> m (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IOException -> IO (Maybe String)
forall a. IOException -> IO a
ioError IOException
collectError))
            (\String
l->if String -> String
removeSpaces String
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":}"
                 then Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
c)
                 else m (Maybe String) -> String -> m (Maybe String)
collectCommand m (Maybe String)
q (String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
normSpace String
l))
      where normSpace :: Char -> Char
normSpace Char
'\r' = Char
' '
            normSpace   Char
x  = Char
x
    -- SDM (2007-11-07): is userError the one to use here?
    collectError :: IOException
collectError = String -> IOException
userError String
"unterminated multiline command :{ .. :}"

    -- | Handle a line of input
    doCommand :: String -> InputT GHCi CommandResult

    -- command
    doCommand :: String -> InputT GHCi CommandResult
doCommand String
stmt | stmt' :: String
stmt'@(Char
':' : String
cmd) <- String -> String
removeSpaces String
stmt = do
      (ActionStats
stats, Either SomeException Bool
result) <- (Bool -> Maybe Integer)
-> InputT GHCi Bool
-> InputT GHCi (ActionStats, Either SomeException Bool)
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(a -> Maybe Integer)
-> m a -> m (ActionStats, Either SomeException a)
runWithStats (Maybe Integer -> Bool -> Maybe Integer
forall a b. a -> b -> a
const Maybe Integer
forall a. Maybe a
Nothing) (InputT GHCi Bool
 -> InputT GHCi (ActionStats, Either SomeException Bool))
-> InputT GHCi Bool
-> InputT GHCi (ActionStats, Either SomeException Bool)
forall a b. (a -> b) -> a -> b
$ String -> InputT GHCi Bool
specialCommand String
cmd
      let processResult :: Bool -> Maybe Bool
processResult Bool
True = Maybe Bool
forall a. Maybe a
Nothing
          processResult Bool
False = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      CommandResult -> InputT GHCi CommandResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CommandResult -> InputT GHCi CommandResult)
-> CommandResult -> InputT GHCi CommandResult
forall a b. (a -> b) -> a -> b
$ String
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete String
stmt' (Bool -> Maybe Bool
processResult (Bool -> Maybe Bool)
-> Either SomeException Bool -> Either SomeException (Maybe Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException Bool
result) ActionStats
stats

    -- haskell
    doCommand String
stmt = do
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt :: Int
stmt_nl_cnt = [()] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ () | Char
'\n' <- String
stmt ]
      Bool
ml <- GHCi Bool -> InputT GHCi Bool
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi Bool -> InputT GHCi Bool) -> GHCi Bool -> InputT GHCi Bool
forall a b. (a -> b) -> a -> b
$ GHCiOption -> GHCi Bool
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m Bool
isOptionSet GHCiOption
Multiline
      if Bool
ml Bool -> Bool -> Bool
&& Int
stmt_nl_cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -- don't trigger automatic multi-line mode for ':{'-multiline input
        then do
          Int
fst_line_num <- GHCiState -> Int
line_number (GHCiState -> Int) -> InputT GHCi GHCiState -> InputT GHCi Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
          Maybe String
mb_stmt <- String -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (Maybe String) -> m (Maybe String)
checkInputForLayout String
stmt InputT GHCi (Maybe String)
gCmd
          case Maybe String
mb_stmt of
            Maybe String
Nothing -> CommandResult -> InputT GHCi CommandResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return CommandResult
CommandIncomplete
            Just String
ml_stmt -> do
              -- temporarily compensate line-number for multi-line input
              (ActionStats
stats, Either SomeException (Maybe ExecResult)
result) <- (Maybe ExecResult -> Maybe Integer)
-> InputT GHCi (Maybe ExecResult)
-> InputT
     GHCi (ActionStats, Either SomeException (Maybe ExecResult))
forall (m :: Type -> Type) a.
GhciMonad m =>
(a -> Maybe Integer)
-> m a -> m (ActionStats, Either SomeException a)
runAndPrintStats Maybe ExecResult -> Maybe Integer
runAllocs (InputT GHCi (Maybe ExecResult)
 -> InputT
      GHCi (ActionStats, Either SomeException (Maybe ExecResult)))
-> InputT GHCi (Maybe ExecResult)
-> InputT
     GHCi (ActionStats, Either SomeException (Maybe ExecResult))
forall a b. (a -> b) -> a -> b
$ GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult))
-> GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult)
forall a b. (a -> b) -> a -> b
$
                Int -> String -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
fst_line_num String
ml_stmt SingleStep
GHC.RunToCompletion
              CommandResult -> InputT GHCi CommandResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CommandResult -> InputT GHCi CommandResult)
-> CommandResult -> InputT GHCi CommandResult
forall a b. (a -> b) -> a -> b
$
                String
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete String
ml_stmt (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool)
-> (Maybe ExecResult -> Bool) -> Maybe ExecResult -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ExecResult -> Bool
runSuccess (Maybe ExecResult -> Maybe Bool)
-> Either SomeException (Maybe ExecResult)
-> Either SomeException (Maybe Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException (Maybe ExecResult)
result) ActionStats
stats
        else do -- single line input and :{ - multiline input
          Int
last_line_num <- GHCiState -> Int
line_number (GHCiState -> Int) -> InputT GHCi GHCiState -> InputT GHCi Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
          -- reconstruct first line num from last line num and stmt
          let fst_line_num :: Int
fst_line_num | Int
stmt_nl_cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int
last_line_num Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stmt_nl_cnt2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                           | Bool
otherwise = Int
last_line_num -- single line input
              stmt_nl_cnt2 :: Int
stmt_nl_cnt2 = [()] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ () | Char
'\n' <- String
stmt' ]
              stmt' :: String
stmt' = String -> String
dropLeadingWhiteLines String
stmt -- runStmt doesn't like leading empty lines
          -- temporarily compensate line-number for multi-line input
          (ActionStats
stats, Either SomeException (Maybe ExecResult)
result) <- (Maybe ExecResult -> Maybe Integer)
-> InputT GHCi (Maybe ExecResult)
-> InputT
     GHCi (ActionStats, Either SomeException (Maybe ExecResult))
forall (m :: Type -> Type) a.
GhciMonad m =>
(a -> Maybe Integer)
-> m a -> m (ActionStats, Either SomeException a)
runAndPrintStats Maybe ExecResult -> Maybe Integer
runAllocs (InputT GHCi (Maybe ExecResult)
 -> InputT
      GHCi (ActionStats, Either SomeException (Maybe ExecResult)))
-> InputT GHCi (Maybe ExecResult)
-> InputT
     GHCi (ActionStats, Either SomeException (Maybe ExecResult))
forall a b. (a -> b) -> a -> b
$ GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult))
-> GHCi (Maybe ExecResult) -> InputT GHCi (Maybe ExecResult)
forall a b. (a -> b) -> a -> b
$
            Int -> String -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
fst_line_num String
stmt' SingleStep
GHC.RunToCompletion
          CommandResult -> InputT GHCi CommandResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CommandResult -> InputT GHCi CommandResult)
-> CommandResult -> InputT GHCi CommandResult
forall a b. (a -> b) -> a -> b
$ String
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete String
stmt' (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool)
-> (Maybe ExecResult -> Bool) -> Maybe ExecResult -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ExecResult -> Bool
runSuccess (Maybe ExecResult -> Maybe Bool)
-> Either SomeException (Maybe ExecResult)
-> Either SomeException (Maybe Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException (Maybe ExecResult)
result) ActionStats
stats

    -- runStmt wrapper for temporarily overridden line-number
    runStmtWithLineNum :: Int -> String -> SingleStep
                       -> GHCi (Maybe GHC.ExecResult)
    runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
lnum String
stmt SingleStep
step = do
        GHCiState
st0 <- GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
        GHCiState -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st0 { line_number :: Int
line_number = Int
lnum }
        Maybe ExecResult
result <- String -> SingleStep -> GHCi (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
String -> SingleStep -> m (Maybe ExecResult)
runStmt String
stmt SingleStep
step
        -- restore original line_number
        GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState GHCi GHCiState -> (GHCiState -> GHCi ()) -> GHCi ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \GHCiState
st -> GHCiState -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st { line_number :: Int
line_number = GHCiState -> Int
line_number GHCiState
st0 }
        Maybe ExecResult -> GHCi (Maybe ExecResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ExecResult
result

    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
    dropLeadingWhiteLines :: String -> String
dropLeadingWhiteLines String
s | (String
l0,Char
'\n':String
r) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') String
s
                            , (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
l0 = String -> String
dropLeadingWhiteLines String
r
                            | Bool
otherwise = String
s


-- #4316
-- lex the input.  If there is an unclosed layout context, request input
checkInputForLayout
  :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)
checkInputForLayout :: String -> m (Maybe String) -> m (Maybe String)
checkInputForLayout String
stmt m (Maybe String)
getStmt = do
   DynFlags
dflags' <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
   let dflags :: DynFlags
dflags = DynFlags -> Extension -> DynFlags
xopt_set DynFlags
dflags' Extension
LangExt.AlternativeLayoutRule
   GHCiState
st0 <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
   let buf' :: StringBuffer
buf'   =  String -> StringBuffer
stringToStringBuffer String
stmt
       loc :: RealSrcLoc
loc    = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit (GHCiState -> String
progname GHCiState
st0)) (GHCiState -> Int
line_number GHCiState
st0) Int
1
       pstate :: PState
pstate = DynFlags -> StringBuffer -> RealSrcLoc -> PState
Lexer.mkPState DynFlags
dflags StringBuffer
buf' RealSrcLoc
loc
   case P Bool -> PState -> ParseResult Bool
forall a. P a -> PState -> ParseResult a
Lexer.unP P Bool
goToEnd PState
pstate of
     (Lexer.POk PState
_ Bool
False) -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
stmt
     ParseResult Bool
_other              -> do
       GHCiState
st1 <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
       let p :: PromptFunction
p = GHCiState -> PromptFunction
prompt GHCiState
st1
       GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st1{ prompt :: PromptFunction
prompt = GHCiState -> PromptFunction
prompt_cont GHCiState
st1 }
       Maybe String
mb_stmt <- (SomeException -> m (Maybe String))
-> m (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type) a.
(HasDynFlags m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle (\SomeException
ex -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex of
                            Just AsyncException
UserInterrupt -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                            Maybe AsyncException
_ -> case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex of
                                 Just GhcException
ghce ->
                                   do IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (GhcException -> IO ()
forall a. Show a => a -> IO ()
print (GhcException
ghce :: GhcException))
                                      Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                                 Maybe GhcException
_other -> IO (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO (Maybe String)
forall e a. Exception e => e -> IO a
Exception.throwIO SomeException
ex))
                     m (Maybe String)
getStmt
       (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st' -> GHCiState
st' { prompt :: PromptFunction
prompt = PromptFunction
p })
       -- the recursive call does not recycle parser state
       -- as we use a new string buffer
       case Maybe String
mb_stmt of
         Maybe String
Nothing  -> Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
         Just String
str -> if String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
           then Maybe String -> m (Maybe String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
stmt
           else do
             String -> m (Maybe String) -> m (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (Maybe String) -> m (Maybe String)
checkInputForLayout (String
stmtString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
str) m (Maybe String)
getStmt
     where goToEnd :: P Bool
goToEnd = do
             Bool
eof <- P Bool
Lexer.nextIsEOF
             if Bool
eof
               then P Bool
Lexer.activeContext
               else Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
Lexer.lexer Bool
False Located Token -> P (Located Token)
forall (m :: Type -> Type) a. Monad m => a -> m a
return P (Located Token) -> P Bool -> P Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> P Bool
goToEnd

enqueueCommands :: GhciMonad m => [String] -> m ()
enqueueCommands :: [String] -> m ()
enqueueCommands [String]
cmds = do
  -- make sure we force any exceptions in the commands while we're
  -- still inside the exception handler, otherwise bad things will
  -- happen (see #10501)
  [String]
cmds [String] -> m () -> m ()
forall a b. NFData a => a -> b -> b
`deepseq` () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st -> GHCiState
st{ cmdqueue :: [String]
cmdqueue = [String]
cmds [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ GHCiState -> [String]
cmdqueue GHCiState
st }

-- | Entry point to execute some haskell code from user.
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
runStmt :: String -> SingleStep -> m (Maybe ExecResult)
runStmt String
input SingleStep
step = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags
  -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
  -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
  -- declarations and statements are not affected.
  -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let source :: String
source = GHCiState -> String
progname GHCiState
st
  let line :: Int
line = GHCiState -> Int
line_number GHCiState
st

  if | DynFlags -> String -> Bool
GHC.isStmt DynFlags
dflags String
input -> do
         HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
         Maybe (GhciLStmt GhcPs)
mb_stmt <- IO (Maybe (GhciLStmt GhcPs)) -> m (Maybe (GhciLStmt GhcPs))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv
-> Hsc (Maybe (GhciLStmt GhcPs)) -> IO (Maybe (GhciLStmt GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
source Int
line String
input))
         case Maybe (GhciLStmt GhcPs)
mb_stmt of
           Maybe (GhciLStmt GhcPs)
Nothing ->
             -- empty statement / comment
             Maybe ExecResult -> m (Maybe ExecResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecResult -> Maybe ExecResult
forall a. a -> Maybe a
Just ExecResult
exec_complete)
           Just GhciLStmt GhcPs
stmt ->
             GhciLStmt GhcPs -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> m (Maybe ExecResult)
run_stmt GhciLStmt GhcPs
stmt

     | DynFlags -> String -> Bool
GHC.isImport DynFlags
dflags String
input -> m (Maybe ExecResult)
run_import

     -- Every import declaration should be handled by `run_import`. As GHCi
     -- in general only accepts one command at a time, we simply throw an
     -- exception when the input contains multiple commands of which at least
     -- one is an import command (see #10663).
     | DynFlags -> String -> Bool
GHC.hasImport DynFlags
dflags String
input -> GhcException -> m (Maybe ExecResult)
forall a. GhcException -> a
throwGhcException
       (String -> GhcException
CmdLineError String
"error: expecting a single import declaration")

     -- Otherwise assume a declaration (or a list of declarations)
     -- Note: `GHC.isDecl` returns False on input like
     -- `data Infix a b = a :@: b; infixl 4 :@:`
     -- and should therefore not be used here.
     | Bool
otherwise -> do
         HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
         [LHsDecl GhcPs]
decls <- IO [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env String
source Int
line String
input)
         [LHsDecl GhcPs] -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
[LHsDecl GhcPs] -> m (Maybe ExecResult)
run_decls [LHsDecl GhcPs]
decls
  where
    exec_complete :: ExecResult
exec_complete = Either SomeException [Name] -> Word64 -> ExecResult
GHC.ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right []) Word64
0

    run_import :: m (Maybe ExecResult)
run_import = do
      String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
addImportToContext String
input
      Maybe ExecResult -> m (Maybe ExecResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecResult -> Maybe ExecResult
forall a. a -> Maybe a
Just ExecResult
exec_complete)

    run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
    run_stmt :: GhciLStmt GhcPs -> m (Maybe ExecResult)
run_stmt GhciLStmt GhcPs
stmt = do
           Maybe ExecResult
m_result <- GhciLStmt GhcPs -> String -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> String -> SingleStep -> m (Maybe ExecResult)
GhciMonad.runStmt GhciLStmt GhcPs
stmt String
input SingleStep
step
           case Maybe ExecResult
m_result of
               Maybe ExecResult
Nothing     -> Maybe ExecResult -> m (Maybe ExecResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ExecResult
forall a. Maybe a
Nothing
               Just ExecResult
result -> ExecResult -> Maybe ExecResult
forall a. a -> Maybe a
Just (ExecResult -> Maybe ExecResult)
-> m ExecResult -> m (Maybe ExecResult)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SrcSpan -> Bool) -> ExecResult -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> ExecResult -> m ExecResult
afterRunStmt (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) ExecResult
result

    -- `x = y` (a declaration) should be treated as `let x = y` (a statement).
    -- The reason is because GHCi wasn't designed to support `x = y`, but then
    -- b98ff3 (#7253) added support for it, except it did not do a good job and
    -- caused problems like:
    --
    --  - not adding the binders defined this way in the necessary places caused
    --    `x = y` to not work in some cases (#12091).
    --  - some GHCi command crashed after `x = y` (#15721)
    --  - warning generation did not work for `x = y` (#11606)
    --  - because `x = y` is a declaration (instead of a statement) differences
    --    in generated code caused confusion (#16089)
    --
    -- Instead of dealing with all these problems individually here we fix this
    -- mess by just treating `x = y` as `let x = y`.
    run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)
    -- Only turn `FunBind` and `VarBind` into statements, other bindings
    -- (e.g. `PatBind`) need to stay as decls.
    run_decls :: [LHsDecl GhcPs] -> m (Maybe ExecResult)
run_decls [L SrcSpan
l (ValD XValD GhcPs
_ bind :: HsBind GhcPs
bind@FunBind{})] = GhciLStmt GhcPs -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> m (Maybe ExecResult)
run_stmt (SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt SrcSpan
l HsBind GhcPs
bind)
    run_decls [L SrcSpan
l (ValD XValD GhcPs
_ bind :: HsBind GhcPs
bind@VarBind{})] = GhciLStmt GhcPs -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> m (Maybe ExecResult)
run_stmt (SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt SrcSpan
l HsBind GhcPs
bind)
    -- Note that any `x = y` declarations below will be run as declarations
    -- instead of statements (e.g. `...; x = y; ...`)
    run_decls [LHsDecl GhcPs]
decls = do
      -- In the new IO library, read handles buffer data even if the Handle
      -- is set to NoBuffering.  This causes problems for GHCi where there
      -- are really two stdin Handles.  So we flush any bufferred data in
      -- GHCi's stdin Handle here (only relevant if stdin is attached to
      -- a file, otherwise the read buffer can't be flushed).
      Either IOException ()
_ <- IO (Either IOException ()) -> m (Either IOException ())
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ()) -> m (Either IOException ()))
-> IO (Either IOException ()) -> m (Either IOException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall a. IO a -> IO (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlushAll Handle
stdin
      Maybe [Name]
m_result <- [LHsDecl GhcPs] -> m (Maybe [Name])
forall (m :: Type -> Type).
GhciMonad m =>
[LHsDecl GhcPs] -> m (Maybe [Name])
GhciMonad.runDecls' [LHsDecl GhcPs]
decls
      Maybe [Name] -> ([Name] -> m ExecResult) -> m (Maybe ExecResult)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe [Name]
m_result (([Name] -> m ExecResult) -> m (Maybe ExecResult))
-> ([Name] -> m ExecResult) -> m (Maybe ExecResult)
forall a b. (a -> b) -> a -> b
$ \[Name]
result ->
        (SrcSpan -> Bool) -> ExecResult -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> ExecResult -> m ExecResult
afterRunStmt (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) (Either SomeException [Name] -> Word64 -> ExecResult
GHC.ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right [Name]
result) Word64
0)

    mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
    mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt SrcSpan
loc HsBind GhcPs
bind =
      let l :: e -> GenLocated SrcSpan e
l = SrcSpan -> e -> GenLocated SrcSpan e
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc
      in StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> GhciLStmt GhcPs
forall e. e -> GenLocated SrcSpan e
l (XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsLocalBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt NoExtField
XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBindsLR GhcPs GhcPs
forall e. e -> GenLocated SrcSpan e
l (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds NoExtField
XHsValBinds GhcPs GhcPs
noExtField (XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds NoExtField
XValBinds GhcPs GhcPs
noExtField (GenLocated SrcSpan (HsBind GhcPs) -> LHsBindsLR GhcPs GhcPs
forall a. a -> Bag a
unitBag (HsBind GhcPs -> GenLocated SrcSpan (HsBind GhcPs)
forall e. e -> GenLocated SrcSpan e
l HsBind GhcPs
bind)) []))))

-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: GhciMonad m
             => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
afterRunStmt :: (SrcSpan -> Bool) -> ExecResult -> m ExecResult
afterRunStmt SrcSpan -> Bool
step_here ExecResult
run_result = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case ExecResult
run_result of
     GHC.ExecComplete{Word64
Either SomeException [Name]
execResult :: ExecResult -> Either SomeException [Name]
execAllocation :: ExecResult -> Word64
execAllocation :: Word64
execResult :: Either SomeException [Name]
..} ->
       case Either SomeException [Name]
execResult of
          Left SomeException
ex -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO SomeException
ex
          Right [Name]
names -> do
            Bool
show_types <- GHCiOption -> m Bool
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m Bool
isOptionSet GHCiOption
ShowType
            Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
show_types (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Name] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Name] -> m ()
printTypeOfNames [Name]
names
     GHC.ExecBreak [Name]
names Maybe BreakInfo
mb_info
         | Maybe BreakInfo -> Bool
forall a. Maybe a -> Bool
isNothing  Maybe BreakInfo
mb_info Bool -> Bool -> Bool
||
           SrcSpan -> Bool
step_here (Resume -> SrcSpan
GHC.resumeSpan (Resume -> SrcSpan) -> Resume -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [Resume] -> Resume
forall a. [a] -> a
head [Resume]
resumes) -> do
               Maybe (Int, BreakLocation)
mb_id_loc <- Maybe BreakInfo -> m (Maybe (Int, BreakLocation))
forall (m :: Type -> Type).
GhciMonad m =>
Maybe BreakInfo -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation Maybe BreakInfo
mb_info
               let bCmd :: String
bCmd = String
-> ((Int, BreakLocation) -> String)
-> Maybe (Int, BreakLocation)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ( \(Int
_,BreakLocation
l) -> BreakLocation -> String
onBreakCmd BreakLocation
l ) Maybe (Int, BreakLocation)
mb_id_loc
               if (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
bCmd)
                 then Resume -> [Name] -> m ()
forall (m :: Type -> Type). GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo ([Resume] -> Resume
forall a. [a] -> a
head [Resume]
resumes) [Name]
names
                 else [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [String
bCmd]
               -- run the command set with ":set stop <cmd>"
               GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
               [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [GHCiState -> String
stop GHCiState
st]
               () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
         | Bool
otherwise -> (SrcSpan -> Bool) -> SingleStep -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ExecResult
resume SrcSpan -> Bool
step_here SingleStep
GHC.SingleStep m ExecResult -> (ExecResult -> m ExecResult) -> m ExecResult
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        (SrcSpan -> Bool) -> ExecResult -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> ExecResult -> m ExecResult
afterRunStmt SrcSpan -> Bool
step_here m ExecResult -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
flushInterpBuffers
  m () -> m ()
forall (m :: Type -> Type) a.
(ExceptionMonad m, MonadIO m) =>
m a -> m a
withSignalHandlers (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
     Bool
b <- GHCiOption -> m Bool
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m Bool
isOptionSet GHCiOption
RevertCAFs
     Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
forall (m :: Type -> Type). GhciMonad m => m ()
revertCAFs

  ExecResult -> m ExecResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecResult
run_result

runSuccess :: Maybe GHC.ExecResult -> Bool
runSuccess :: Maybe ExecResult -> Bool
runSuccess Maybe ExecResult
run_result
  | Just (GHC.ExecComplete { execResult :: ExecResult -> Either SomeException [Name]
execResult = Right [Name]
_ }) <- Maybe ExecResult
run_result = Bool
True
  | Bool
otherwise = Bool
False

runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
runAllocs :: Maybe ExecResult -> Maybe Integer
runAllocs Maybe ExecResult
m = do
  ExecResult
res <- Maybe ExecResult
m
  case ExecResult
res of
    GHC.ExecComplete{Word64
Either SomeException [Name]
execAllocation :: Word64
execResult :: Either SomeException [Name]
execResult :: ExecResult -> Either SomeException [Name]
execAllocation :: ExecResult -> Word64
..} -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
execAllocation)
    ExecResult
_ -> Maybe Integer
forall a. Maybe a
Nothing

toBreakIdAndLocation :: GhciMonad m
                     => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation :: Maybe BreakInfo -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation Maybe BreakInfo
Nothing = Maybe (Int, BreakLocation) -> m (Maybe (Int, BreakLocation))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Int, BreakLocation)
forall a. Maybe a
Nothing
toBreakIdAndLocation (Just BreakInfo
inf) = do
  let md :: Module
md = BreakInfo -> Module
GHC.breakInfo_module BreakInfo
inf
      nm :: Int
nm = BreakInfo -> Int
GHC.breakInfo_number BreakInfo
inf
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  Maybe (Int, BreakLocation) -> m (Maybe (Int, BreakLocation))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Int, BreakLocation) -> m (Maybe (Int, BreakLocation)))
-> Maybe (Int, BreakLocation) -> m (Maybe (Int, BreakLocation))
forall a b. (a -> b) -> a -> b
$ [(Int, BreakLocation)] -> Maybe (Int, BreakLocation)
forall a. [a] -> Maybe a
listToMaybe [ (Int, BreakLocation)
id_loc | id_loc :: (Int, BreakLocation)
id_loc@(Int
_,BreakLocation
loc) <- IntMap BreakLocation -> [(Int, BreakLocation)]
forall a. IntMap a -> [(Int, a)]
IntMap.assocs (GHCiState -> IntMap BreakLocation
breaks GHCiState
st),
                                  BreakLocation -> Module
breakModule BreakLocation
loc Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
md,
                                  BreakLocation -> Int
breakTick BreakLocation
loc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nm ]

printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo :: Resume -> [Name] -> m ()
printStoppedAtBreakInfo Resume
res [Name]
names = do
  MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ Resume -> MsgDoc
pprStopped Resume
res
  --  printTypeOfNames session names
  let namesSorted :: [Name]
namesSorted = (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Name -> Name -> Ordering
compareNames [Name]
names
  [TyThing]
tythings <- [Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TyThing] -> [TyThing]) -> m [Maybe TyThing] -> m [TyThing]
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
`liftM` (Name -> m (Maybe TyThing)) -> [Name] -> m [Maybe TyThing]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName [Name]
namesSorted
  [MsgDoc]
docs <- (Id -> m MsgDoc) -> [Id] -> m [MsgDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> m MsgDoc
forall (m :: Type -> Type). GhcMonad m => Id -> m MsgDoc
pprTypeAndContents [Id
i | AnId Id
i <- [TyThing]
tythings]
  MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUserPartWay (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [MsgDoc]
docs

printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
printTypeOfNames :: [Name] -> m ()
printTypeOfNames [Name]
names
 = (Name -> m ()) -> [Name] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name -> m ()
forall (m :: Type -> Type). GhcMonad m => Name -> m ()
printTypeOfName ) ([Name] -> m ()) -> [Name] -> m ()
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Name -> Name -> Ordering
compareNames [Name]
names

compareNames :: Name -> Name -> Ordering
Name
n1 compareNames :: Name -> Name -> Ordering
`compareNames` Name
n2 = Name -> (String, SrcSpan)
forall a. NamedThing a => a -> (String, SrcSpan)
compareWith Name
n1 (String, SrcSpan) -> (String, SrcSpan) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name -> (String, SrcSpan)
forall a. NamedThing a => a -> (String, SrcSpan)
compareWith Name
n2
    where compareWith :: a -> (String, SrcSpan)
compareWith a
n = (a -> String
forall a. NamedThing a => a -> String
getOccString a
n, a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
n)

printTypeOfName :: GHC.GhcMonad m => Name -> m ()
printTypeOfName :: Name -> m ()
printTypeOfName Name
n
   = do Maybe TyThing
maybe_tything <- Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName Name
n
        case Maybe TyThing
maybe_tything of
            Maybe TyThing
Nothing    -> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
            Just TyThing
thing -> TyThing -> m ()
forall (m :: Type -> Type). GhcMonad m => TyThing -> m ()
printTyThing TyThing
thing


data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand

-- | Entry point for execution a ':<command>' input from user
specialCommand :: String -> InputT GHCi Bool
specialCommand :: String -> InputT GHCi Bool
specialCommand (Char
'!':String
str) = GHCi Bool -> InputT GHCi Bool
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi Bool -> InputT GHCi Bool) -> GHCi Bool -> InputT GHCi Bool
forall a b. (a -> b) -> a -> b
$ String -> GHCi Bool
forall (m :: Type -> Type). MonadIO m => String -> m Bool
shellEscape ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str)
specialCommand String
str = do
  let (String
cmd,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
str
  MaybeCommand
maybe_cmd <- String -> InputT GHCi MaybeCommand
forall (m :: Type -> Type). GhciMonad m => String -> m MaybeCommand
lookupCommand String
cmd
  String
htxt <- GHCiState -> String
short_help (GHCiState -> String)
-> InputT GHCi GHCiState -> InputT GHCi String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  case MaybeCommand
maybe_cmd of
    GotCommand Command
cmd -> (Command -> String -> InputT GHCi Bool
cmdAction Command
cmd) ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest)
    MaybeCommand
BadCommand ->
      do IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ()) -> IO () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stdout (String
"unknown command ':" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
htxt)
         Bool -> InputT GHCi Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
    MaybeCommand
NoLastCommand ->
      do IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ()) -> IO () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stdout (String
"there is no last command to perform\n"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
htxt)
         Bool -> InputT GHCi Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

shellEscape :: MonadIO m => String -> m Bool
shellEscape :: String -> m Bool
shellEscape String
str = IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ExitCode
system String
str IO ExitCode -> IO Bool -> IO Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False)

lookupCommand :: GhciMonad m => String -> m (MaybeCommand)
lookupCommand :: String -> m MaybeCommand
lookupCommand String
"" = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  case GHCiState -> Maybe Command
last_command GHCiState
st of
      Just Command
c -> MaybeCommand -> m MaybeCommand
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MaybeCommand -> m MaybeCommand) -> MaybeCommand -> m MaybeCommand
forall a b. (a -> b) -> a -> b
$ Command -> MaybeCommand
GotCommand Command
c
      Maybe Command
Nothing -> MaybeCommand -> m MaybeCommand
forall (m :: Type -> Type) a. Monad m => a -> m a
return MaybeCommand
NoLastCommand
lookupCommand String
str = do
  Maybe Command
mc <- String -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (Maybe Command)
lookupCommand' String
str
  (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { last_command :: Maybe Command
last_command = Maybe Command
mc })
  MaybeCommand -> m MaybeCommand
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MaybeCommand -> m MaybeCommand) -> MaybeCommand -> m MaybeCommand
forall a b. (a -> b) -> a -> b
$ case Maybe Command
mc of
           Just Command
c -> Command -> MaybeCommand
GotCommand Command
c
           Maybe Command
Nothing -> MaybeCommand
BadCommand

lookupCommand' :: GhciMonad m => String -> m (Maybe Command)
lookupCommand' :: String -> m (Maybe Command)
lookupCommand' String
":" = Maybe Command -> m (Maybe Command)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Command
forall a. Maybe a
Nothing
lookupCommand' String
str' = do
  [Command]
macros    <- GHCiState -> [Command]
ghci_macros (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  [Command]
ghci_cmds <- GHCiState -> [Command]
ghci_commands (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState

  let ghci_cmds_nohide :: [Command]
ghci_cmds_nohide = (Command -> Bool) -> [Command] -> [Command]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Command -> Bool) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> Bool
cmdHidden) [Command]
ghci_cmds

  let (String
str, [Command]
xcmds) = case String
str' of
          Char
':' : String
rest -> (String
rest, [])     -- "::" selects a builtin command
          String
_          -> (String
str', [Command]
macros) -- otherwise include macros in lookup

      lookupExact :: String -> t Command -> Maybe Command
lookupExact  String
s = (Command -> Bool) -> t Command -> Maybe Command
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((Command -> Bool) -> t Command -> Maybe Command)
-> (Command -> Bool) -> t Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ (String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==)              (String -> Bool) -> (Command -> String) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> String
cmdName
      lookupPrefix :: String -> t Command -> Maybe Command
lookupPrefix String
s = (Command -> Bool) -> t Command -> Maybe Command
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((Command -> Bool) -> t Command -> Maybe Command)
-> (Command -> Bool) -> t Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ (String
s String -> String -> Bool
`isPrefixOptOf`) (String -> Bool) -> (Command -> String) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> String
cmdName

      -- hidden commands can only be matched exact
      builtinPfxMatch :: Maybe Command
builtinPfxMatch = String -> [Command] -> Maybe Command
forall (t :: Type -> Type).
Foldable t =>
String -> t Command -> Maybe Command
lookupPrefix String
str [Command]
ghci_cmds_nohide

  -- first, look for exact match (while preferring macros); then, look
  -- for first prefix match (preferring builtins), *unless* a macro
  -- overrides the builtin; see #8305 for motivation
  Maybe Command -> m (Maybe Command)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Command -> m (Maybe Command))
-> Maybe Command -> m (Maybe Command)
forall a b. (a -> b) -> a -> b
$ String -> [Command] -> Maybe Command
forall (t :: Type -> Type).
Foldable t =>
String -> t Command -> Maybe Command
lookupExact String
str [Command]
xcmds Maybe Command -> Maybe Command -> Maybe Command
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           String -> [Command] -> Maybe Command
forall (t :: Type -> Type).
Foldable t =>
String -> t Command -> Maybe Command
lookupExact String
str [Command]
ghci_cmds Maybe Command -> Maybe Command -> Maybe Command
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           (Maybe Command
builtinPfxMatch Maybe Command -> (Command -> Maybe Command) -> Maybe Command
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Command
c -> String -> [Command] -> Maybe Command
forall (t :: Type -> Type).
Foldable t =>
String -> t Command -> Maybe Command
lookupExact (Command -> String
cmdName Command
c) [Command]
xcmds) Maybe Command -> Maybe Command -> Maybe Command
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           Maybe Command
builtinPfxMatch Maybe Command -> Maybe Command -> Maybe Command
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           String -> [Command] -> Maybe Command
forall (t :: Type -> Type).
Foldable t =>
String -> t Command -> Maybe Command
lookupPrefix String
str [Command]
xcmds

-- This predicate is for prefix match with a command-body and
-- suffix match with an option, such as `!`.
-- The current implementation assumes only the `!` character
-- as the option delimiter.
-- See also #17345
isPrefixOptOf :: String -> String -> Bool
isPrefixOptOf :: String -> String -> Bool
isPrefixOptOf String
s String
x = let (String
body, String
opt) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!') String
s
                    in  (String
body String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x) Bool -> Bool -> Bool
&& (String
opt String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
x)

getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan :: m (Maybe SrcSpan)
getCurrentBreakSpan = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case [Resume]
resumes of
    [] -> Maybe SrcSpan -> m (Maybe SrcSpan)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe SrcSpan
forall a. Maybe a
Nothing
    (Resume
r:[Resume]
_) -> do
        let ix :: Int
ix = Resume -> Int
GHC.resumeHistoryIx Resume
r
        if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
           then Maybe SrcSpan -> m (Maybe SrcSpan)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (Resume -> SrcSpan
GHC.resumeSpan Resume
r))
           else do
                let hist :: History
hist = Resume -> [History]
GHC.resumeHistory Resume
r [History] -> Int -> History
forall a. [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                SrcSpan
pan <- History -> m SrcSpan
forall (m :: Type -> Type). GhcMonad m => History -> m SrcSpan
GHC.getHistorySpan History
hist
                Maybe SrcSpan -> m (Maybe SrcSpan)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
pan)

getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])
getCallStackAtCurrentBreakpoint :: m (Maybe [String])
getCallStackAtCurrentBreakpoint = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case [Resume]
resumes of
    [] -> Maybe [String] -> m (Maybe [String])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [String]
forall a. Maybe a
Nothing
    (Resume
r:[Resume]
_) -> do
       HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
       [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> m [String] -> m (Maybe [String])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo HscEnv
hsc_env (Resume -> RemotePtr CostCentreStack
GHC.resumeCCS Resume
r))

getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
getCurrentBreakModule :: m (Maybe Module)
getCurrentBreakModule = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case [Resume]
resumes of
    [] -> Maybe Module -> m (Maybe Module)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Module
forall a. Maybe a
Nothing
    (Resume
r:[Resume]
_) -> do
        let ix :: Int
ix = Resume -> Int
GHC.resumeHistoryIx Resume
r
        if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
           then Maybe Module -> m (Maybe Module)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BreakInfo -> Module
GHC.breakInfo_module (BreakInfo -> Module) -> Maybe BreakInfo -> Maybe Module
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
`liftM` Resume -> Maybe BreakInfo
GHC.resumeBreakInfo Resume
r)
           else do
                let hist :: History
hist = Resume -> [History]
GHC.resumeHistory Resume
r [History] -> Int -> History
forall a. [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                Maybe Module -> m (Maybe Module)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Module -> m (Maybe Module))
-> Maybe Module -> m (Maybe Module)
forall a b. (a -> b) -> a -> b
$ Module -> Maybe Module
forall a. a -> Maybe a
Just (Module -> Maybe Module) -> Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$ History -> Module
GHC.getHistoryModule  History
hist

-----------------------------------------------------------------------------
--
-- Commands
--
-----------------------------------------------------------------------------

noArgs :: MonadIO m => m () -> String -> m ()
noArgs :: m () -> String -> m ()
noArgs m ()
m String
"" = m ()
m
noArgs m ()
_ String
_  = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"This command takes no arguments"

withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()
withSandboxOnly :: String -> m () -> m ()
withSandboxOnly String
cmd m ()
this = do
   DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
   if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciSandbox DynFlags
dflags)
      then MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (String -> MsgDoc
text String
cmd MsgDoc -> MsgDoc -> MsgDoc
<+>
                         PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"is not supported with -fno-ghci-sandbox"))
      else m ()
this

-----------------------------------------------------------------------------
-- :help

help :: GhciMonad m => String -> m ()
help :: String -> m ()
help String
_ = do
    String
txt <- GHCiState -> String
long_help (GHCiState -> String) -> m GHCiState -> m String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
txt

-----------------------------------------------------------------------------
-- :info

info :: GHC.GhcMonad m => Bool -> String -> m ()
info :: Bool -> String -> m ()
info Bool
_ String
"" = GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax: ':i <thing-you-want-info-about>'")
info Bool
allInfo String
s  = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    PrintUnqualified
unqual <- m PrintUnqualified
forall (m :: Type -> Type). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    [MsgDoc]
sdocs  <- (String -> m MsgDoc) -> [String] -> m [MsgDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> String -> m MsgDoc
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> String -> m MsgDoc
infoThing Bool
allInfo) (String -> [String]
words String
s)
    (MsgDoc -> m ()) -> [MsgDoc] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (MsgDoc -> IO ()) -> MsgDoc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (MsgDoc -> String) -> MsgDoc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
unqual) [MsgDoc]
sdocs

infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
infoThing :: Bool -> String -> m MsgDoc
infoThing Bool
allInfo String
str = do
    [Name]
names     <- String -> m [Name]
forall (m :: Type -> Type). GhcMonad m => String -> m [Name]
GHC.parseName String
str
    [Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
mb_stuffs <- (Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)))
-> [Name]
-> m [Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> Name
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: Type -> Type).
GhcMonad m =>
Bool
-> Name
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
GHC.getInfo Bool
allInfo) [Name]
names
    let filtered :: [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
filtered = ((TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> TyThing)
-> [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren (\(TyThing
t,Fixity
_f,[ClsInst]
_ci,[FamInst]
_fi,MsgDoc
_sd) -> TyThing
t)
                                     ([Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
mb_stuffs)
    MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> m MsgDoc) -> MsgDoc -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat (MsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
intersperse (String -> MsgDoc
text String
"") ([MsgDoc] -> [MsgDoc]) -> [MsgDoc] -> [MsgDoc]
forall a b. (a -> b) -> a -> b
$ ((TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc)
-> [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc
pprInfo [(TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)]
filtered)

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren a -> TyThing
get_thing [a]
xs
  = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterOut a -> Bool
has_parent [a]
xs
  where
    all_names :: NameSet
all_names = [Name] -> NameSet
mkNameSet ((a -> Name) -> [a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyThing -> Name
forall a. NamedThing a => a -> Name
getName (TyThing -> Name) -> (a -> TyThing) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TyThing
get_thing) [a]
xs)
    has_parent :: a -> Bool
has_parent a
x = case TyThing -> Maybe TyThing
tyThingParent_maybe (a -> TyThing
get_thing a
x) of
                     Just TyThing
p  -> TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
p Name -> NameSet -> Bool
`elemNameSet` NameSet
all_names
                     Maybe TyThing
Nothing -> Bool
False

pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
pprInfo :: (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc
pprInfo (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, MsgDoc
docs)
  =  MsgDoc
docs
  MsgDoc -> MsgDoc -> MsgDoc
$$ TyThing -> MsgDoc
pprTyThingInContextLoc TyThing
thing
  MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
show_fixity
  MsgDoc -> MsgDoc -> MsgDoc
$$ [MsgDoc] -> MsgDoc
vcat ((ClsInst -> MsgDoc) -> [ClsInst] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> MsgDoc
GHC.pprInstance [ClsInst]
cls_insts)
  MsgDoc -> MsgDoc -> MsgDoc
$$ [MsgDoc] -> MsgDoc
vcat ((FamInst -> MsgDoc) -> [FamInst] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> MsgDoc
GHC.pprFamInst  [FamInst]
fam_insts)
  where
    show_fixity :: MsgDoc
show_fixity
        | Fixity
fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
GHC.defaultFixity = MsgDoc
empty
        | Bool
otherwise                   = Fixity -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Fixity
fixity MsgDoc -> MsgDoc -> MsgDoc
<+> Name -> MsgDoc
forall a. (Outputable a, NamedThing a) => a -> MsgDoc
pprInfixName (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
thing)

-----------------------------------------------------------------------------
-- :main

runMain :: GhciMonad m => String -> m ()
runMain :: String -> m ()
runMain String
s = case String -> Either String [String]
toArgs String
s of
            Left String
err   -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err)
            Right [String]
args ->
                do DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
                   let main :: String
main = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"main" (DynFlags -> Maybe String
mainFunIs DynFlags
dflags)
                   -- Wrap the main function in 'void' to discard its value instead
                   -- of printing it (#9086). See Haskell 2010 report Chapter 5.
                   [String] -> String -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[String] -> String -> m ()
doWithArgs [String]
args (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Control.Monad.void (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
main String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-----------------------------------------------------------------------------
-- :run

runRun :: GhciMonad m => String -> m ()
runRun :: String -> m ()
runRun String
s = case String -> Either String (String, [String])
toCmdArgs String
s of
           Left String
err          -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err)
           Right (String
cmd, [String]
args) -> [String] -> String -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[String] -> String -> m ()
doWithArgs [String]
args String
cmd

doWithArgs :: GhciMonad m => [String] -> String -> m ()
doWithArgs :: [String] -> String -> m ()
doWithArgs [String]
args String
cmd = [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [String
"System.Environment.withArgs " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       [String] -> String
forall a. Show a => a -> String
show [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"]

-----------------------------------------------------------------------------
-- :cd

changeDirectory :: GhciMonad m => String -> m ()
changeDirectory :: String -> m ()
changeDirectory String
"" = do
  -- :cd on its own changes to the user's home directory
  Either IOException String
either_dir <- IO (Either IOException String) -> m (Either IOException String)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException String) -> m (Either IOException String))
-> IO (Either IOException String) -> m (Either IOException String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO IO String
getHomeDirectory
  case Either IOException String
either_dir of
     Left IOException
_e -> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
     Right String
dir -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
changeDirectory String
dir
changeDirectory String
dir = do
  ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([ModSummary] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([ModSummary] -> Bool) -> [ModSummary] -> Bool
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
  -- delete targets and all eventually defined breakpoints (#1620)
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearAllTargets
  Bool -> [ModSummary] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [ModSummary] -> m ()
setContextAfterLoad Bool
False []
  m ()
forall (m :: Type -> Type). GhcMonad m => m ()
GHC.workingDirectoryChanged
  String
dir' <- String -> m String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath String
dir
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir'
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
  -- (this gives consistent behaviour with and without -fexternal-interpreter)
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    ForeignHValue
fhv <- String -> m ForeignHValue
forall (m :: Type -> Type). GhcMonad m => String -> m ForeignHValue
compileGHCiExpr (String -> m ForeignHValue) -> String -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$
      String
"System.Directory.setCurrentDirectory " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
dir'
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignHValue -> IO ()
evalIO HscEnv
hsc_env ForeignHValue
fhv

trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
trySuccess :: m SuccessFlag -> m SuccessFlag
trySuccess m SuccessFlag
act =
    (SourceError -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e
                                SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
Failed) (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
      m SuccessFlag
act

-----------------------------------------------------------------------------
-- :edit

editFile :: GhciMonad m => String -> m ()
editFile :: String -> m ()
editFile String
str =
  do String
file <- if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
str then m String
forall (m :: Type -> Type). GhcMonad m => m String
chooseEditFile else String -> m String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath String
str
     GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
     [(FastString, Int)]
errs <- IO [(FastString, Int)] -> m [(FastString, Int)]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(FastString, Int)] -> m [(FastString, Int)])
-> IO [(FastString, Int)] -> m [(FastString, Int)]
forall a b. (a -> b) -> a -> b
$ IORef [(FastString, Int)] -> IO [(FastString, Int)]
forall a. IORef a -> IO a
readIORef (IORef [(FastString, Int)] -> IO [(FastString, Int)])
-> IORef [(FastString, Int)] -> IO [(FastString, Int)]
forall a b. (a -> b) -> a -> b
$ GHCiState -> IORef [(FastString, Int)]
lastErrorLocations GHCiState
st
     let cmd :: String
cmd = GHCiState -> String
editor GHCiState
st
     Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
cmd)
       (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"editor not set, use :set editor")
     String
lineOpt <- IO String -> m String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ do
         let sameFile :: String -> String -> IO Bool
sameFile String
p1 String
p2 = (String -> String -> Bool) -> IO String -> IO String -> IO Bool
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> IO String
canonicalizePath String
p1) (String -> IO String
canonicalizePath String
p2)
              IO Bool -> (IOException -> IO Bool) -> IO Bool
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False)

         [(FastString, Int)]
curFileErrs <- ((FastString, Int) -> IO Bool)
-> [(FastString, Int)] -> IO [(FastString, Int)]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(FastString
f, Int
_) -> FastString -> String
unpackFS FastString
f String -> String -> IO Bool
`sameFile` String
file) [(FastString, Int)]
errs
         String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case [(FastString, Int)]
curFileErrs of
             (FastString
_, Int
line):[(FastString, Int)]
_ -> String
" +" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line
             [(FastString, Int)]
_ -> String
""
     let cmdArgs :: String
cmdArgs = Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:(String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lineOpt)
     ExitCode
code <- IO ExitCode -> m ExitCode
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ String -> IO ExitCode
system (String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdArgs)

     Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess)
       (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModule String
""

-- The user didn't specify a file so we pick one for them.
-- Our strategy is to pick the first module that failed to load,
-- or otherwise the first target.
--
-- XXX: Can we figure out what happened if the depndecy analysis fails
--      (e.g., because the porgrammeer mistyped the name of a module)?
-- XXX: Can we figure out the location of an error to pass to the editor?
-- XXX: if we could figure out the list of errors that occured during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHC.GhcMonad m => m String
chooseEditFile :: m String
chooseEditFile =
  do let hasFailed :: ModSummary -> f Bool
hasFailed ModSummary
x = (Bool -> Bool) -> f Bool -> f Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (f Bool -> f Bool) -> f Bool -> f Bool
forall a b. (a -> b) -> a -> b
$ ModuleName -> f Bool
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded (ModuleName -> f Bool) -> ModuleName -> f Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
x

     ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
     ModuleGraph
failed_graph <-
       [ModSummary] -> ModuleGraph
GHC.mkModuleGraph ([ModSummary] -> ModuleGraph) -> m [ModSummary] -> m ModuleGraph
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModSummary -> m Bool) -> [ModSummary] -> m [ModSummary]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModSummary -> m Bool
forall (f :: Type -> Type). GhcMonad f => ModSummary -> f Bool
hasFailed (ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph)
     let order :: ModuleGraph -> [ModSummary]
order ModuleGraph
g  = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ModuleGraph
g Maybe ModuleName
forall a. Maybe a
Nothing
         pick :: [ModSummary] -> Maybe String
pick [ModSummary]
xs  = case [ModSummary]
xs of
                      ModSummary
x : [ModSummary]
_ -> ModLocation -> Maybe String
GHC.ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
x)
                      [ModSummary]
_     -> Maybe String
forall a. Maybe a
Nothing

     case [ModSummary] -> Maybe String
pick (ModuleGraph -> [ModSummary]
order ModuleGraph
failed_graph) of
       Just String
file -> String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
file
       Maybe String
Nothing   ->
         do [Target]
targets <- m [Target]
forall (m :: Type -> Type). GhcMonad m => m [Target]
GHC.getTargets
            case [Maybe String] -> Maybe String
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((Target -> Maybe String) -> [Target] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map Target -> Maybe String
fromTarget [Target]
targets) of
              Just String
file -> String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
file
              Maybe String
Nothing   -> GhcException -> m String
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"No files to edit.")

  where fromTarget :: Target -> Maybe String
fromTarget (GHC.Target (GHC.TargetFile String
f Maybe Phase
_) Bool
_ Maybe (StringBuffer, UTCTime)
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
f
        fromTarget Target
_ = Maybe String
forall a. Maybe a
Nothing -- when would we get a module target?


-----------------------------------------------------------------------------
-- :def

defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
defineMacro :: Bool -> String -> m ()
defineMacro Bool
_ (Char
':':String
_) = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
                          String
"macro name cannot start with a colon"
defineMacro Bool
_ (Char
'!':String
_) = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
                          String
"macro name cannot start with an exclamation mark"
                          -- little code duplication allows to grep error msg
defineMacro Bool
overwrite String
s = do
  let (String
macro_name, String
definition) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
s
  [Command]
macros <- GHCiState -> [Command]
ghci_macros (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let defined :: [String]
defined = (Command -> String) -> [Command] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Command -> String
cmdName [Command]
macros
  if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
macro_name
        then if [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
defined
                then IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"no macros defined"
                else IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
"the following macros are defined:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      [String] -> String
unlines [String]
defined)
  else do
    Bool
isCommand <- Maybe Command -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Command -> Bool) -> m (Maybe Command) -> m Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (Maybe Command)
lookupCommand' String
macro_name
    let check_newname :: m ()
check_newname
          | String
macro_name String -> [String] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [String]
defined = GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError
            (String
"macro '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
macro_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is already defined. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hint))
          | Bool
isCommand = GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError
            (String
"macro '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
macro_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' overwrites builtin command. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hint))
          | Bool
otherwise = () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        hint :: String
hint = String
" Use ':def!' to overwrite."

    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
overwrite m ()
check_newname
    -- compile the expression
    (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      LHsExpr GhcPs
step <- m (LHsExpr GhcPs)
forall (m :: Type -> Type). GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO
      LHsExpr GhcPs
expr <- String -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
GhcMonad m =>
String -> m (LHsExpr GhcPs)
GHC.parseExpr String
definition
      -- > ghciStepIO . definition :: String -> IO String
      let stringTy :: LHsType GhcPs
stringTy = IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar IdP GhcPs
RdrName
stringTy_RDR
          ioM :: LHsType GhcPs
ioM = IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
ioTyConName) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsAppTy` LHsType GhcPs
stringTy
          body :: LHsExpr GhcPs
body = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdP GhcPs
RdrName
compose_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar LHsExpr GhcPs
step)
                                     LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar LHsExpr GhcPs
expr)
          tySig :: LHsSigWcType GhcPs
tySig = LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType (LHsType GhcPs
stringTy LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsFunTy` LHsType GhcPs
ioM)
          new_expr :: LHsExpr GhcPs
new_expr = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
expr) (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noExtField LHsExpr GhcPs
body LHsSigWcType GhcPs
LHsSigWcType (NoGhcTc GhcPs)
tySig
      ForeignHValue
hv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
GHC.compileParsedExprRemote LHsExpr GhcPs
new_expr

      let newCmd :: Command
newCmd = Command :: String
-> (String -> InputT GHCi Bool)
-> Bool
-> CompletionFunc GHCi
-> Command
Command { cmdName :: String
cmdName = String
macro_name
                           , cmdAction :: String -> InputT GHCi Bool
cmdAction = GHCi Bool -> InputT GHCi Bool
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi Bool -> InputT GHCi Bool)
-> (String -> GHCi Bool) -> String -> InputT GHCi Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignHValue -> String -> GHCi Bool
forall (m :: Type -> Type).
GhciMonad m =>
ForeignHValue -> String -> m Bool
runMacro ForeignHValue
hv
                           , cmdHidden :: Bool
cmdHidden = Bool
False
                           , cmdCompletionFunc :: CompletionFunc GHCi
cmdCompletionFunc = CompletionFunc GHCi
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion
                           }

      -- later defined macros have precedence
      (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
s ->
        let filtered :: [Command]
filtered = [ Command
cmd | Command
cmd <- [Command]
macros, Command -> String
cmdName Command
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
macro_name ]
        in GHCiState
s { ghci_macros :: [Command]
ghci_macros = Command
newCmd Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: [Command]
filtered }

runMacro
  :: GhciMonad m
  => GHC.ForeignHValue  -- String -> IO String
  -> String
  -> m Bool
runMacro :: ForeignHValue -> String -> m Bool
runMacro ForeignHValue
fun String
s = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  String
str <- IO String -> m String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignHValue -> String -> IO String
evalStringToIOString HscEnv
hsc_env ForeignHValue
fun String
s
  [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands (String -> [String]
lines String
str)
  Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False


-----------------------------------------------------------------------------
-- :undef

undefineMacro :: GhciMonad m => String -> m ()
undefineMacro :: String -> m ()
undefineMacro String
str = (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
undef (String -> [String]
words String
str)
 where undef :: String -> m ()
undef String
macro_name = do
        [Command]
cmds <- GHCiState -> [Command]
ghci_macros (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
        if (String
macro_name String -> [String] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` (Command -> String) -> [Command] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Command -> String
cmdName [Command]
cmds)
           then GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError
                (String
"macro '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
macro_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not defined"))
           else do
            -- This is a tad racy but really, it's a shell
            (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
s ->
                GHCiState
s { ghci_macros :: [Command]
ghci_macros = (Command -> Bool) -> [Command] -> [Command]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
macro_name) (String -> Bool) -> (Command -> String) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> String
cmdName)
                                         (GHCiState -> [Command]
ghci_macros GHCiState
s) }


-----------------------------------------------------------------------------
-- :cmd

cmdCmd :: GhciMonad m => String -> m ()
cmdCmd :: String -> m ()
cmdCmd String
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    LHsExpr GhcPs
step <- m (LHsExpr GhcPs)
forall (m :: Type -> Type). GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO
    LHsExpr GhcPs
expr <- String -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
GhcMonad m =>
String -> m (LHsExpr GhcPs)
GHC.parseExpr String
str
    -- > ghciStepIO str :: IO String
    let new_expr :: LHsExpr GhcPs
new_expr = LHsExpr GhcPs
step LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` LHsExpr GhcPs
expr
    ForeignHValue
hv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
GHC.compileParsedExprRemote LHsExpr GhcPs
new_expr

    HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    String
cmds <- IO String -> m String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignHValue -> IO String
evalString HscEnv
hsc_env ForeignHValue
hv
    [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands (String -> [String]
lines String
cmds)

-- | Generate a typed ghciStepIO expression
-- @ghciStepIO :: Ty String -> IO String@.
getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO :: m (LHsExpr GhcPs)
getGhciStepIO = do
  Name
ghciTyConName <- m Name
forall (m :: Type -> Type). GhcMonad m => m Name
GHC.getGHCiMonad
  let stringTy :: LHsType GhcPs
stringTy = IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar IdP GhcPs
RdrName
stringTy_RDR
      ghciM :: LHsType GhcPs
ghciM = IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
ghciTyConName) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsAppTy` LHsType GhcPs
stringTy
      ioM :: LHsType GhcPs
ioM = IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
ioTyConName) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsAppTy` LHsType GhcPs
stringTy
      body :: LHsExpr GhcPs
body = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
ghciStepIoMName)
      tySig :: LHsSigWcType GhcPs
tySig = LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType (LHsType GhcPs
ghciM LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
`nlHsFunTy` LHsType GhcPs
ioM)
  LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noExtField LHsExpr GhcPs
body LHsSigWcType GhcPs
LHsSigWcType (NoGhcTc GhcPs)
tySig

-----------------------------------------------------------------------------
-- :check

checkModule :: GhciMonad m => String -> m ()
checkModule :: String -> m ()
checkModule String
m = do
  let modl :: ModuleName
modl = String -> ModuleName
GHC.mkModuleName String
m
  Bool
ok <- (SourceError -> m Bool) -> m Bool -> m Bool
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e m () -> m Bool -> m Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
          TypecheckedModule
r <- ParsedModule -> m TypecheckedModule
forall (m :: Type -> Type).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
GHC.typecheckModule (ParsedModule -> m TypecheckedModule)
-> m ParsedModule -> m TypecheckedModule
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
GHC.parseModule (ModSummary -> m ParsedModule) -> m ModSummary -> m ParsedModule
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModuleName -> m ModSummary
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m ModSummary
GHC.getModSummary ModuleName
modl
          DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
          IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
           case TypecheckedModule -> ModuleInfo
forall m. TypecheckedMod m => m -> ModuleInfo
GHC.moduleInfo TypecheckedModule
r of
             ModuleInfo
cm | Just [Name]
scope <- ModuleInfo -> Maybe [Name]
GHC.modInfoTopLevelScope ModuleInfo
cm ->
                let
                    ([Name]
loc, [Name]
glob) = ASSERT( all isExternalName scope )
                                  (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
modl) (ModuleName -> Bool) -> (Name -> ModuleName) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
GHC.moduleName (Module -> ModuleName) -> (Name -> Module) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
GHC.nameModule) [Name]
scope
                in
                        (String -> MsgDoc
text String
"global names: " MsgDoc -> MsgDoc -> MsgDoc
<+> [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
glob) MsgDoc -> MsgDoc -> MsgDoc
$$
                        (String -> MsgDoc
text String
"local  names: " MsgDoc -> MsgDoc -> MsgDoc
<+> [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
loc)
             ModuleInfo
_ -> MsgDoc
empty
          Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
  SuccessFlag -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
SuccessFlag -> Bool -> m ()
afterLoad (Bool -> SuccessFlag
successIf Bool
ok) Bool
False

-----------------------------------------------------------------------------
-- :doc

docCmd :: GHC.GhcMonad m => String -> m ()
docCmd :: String -> m ()
docCmd String
"" =
  GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax: ':doc <thing-you-want-docs-for>'")
docCmd String
s  = do
  -- TODO: Maybe also get module headers for module names
  [Name]
names <- String -> m [Name]
forall (m :: Type -> Type). GhcMonad m => String -> m [Name]
GHC.parseName String
s
  [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
e_docss <- (Name
 -> m (Either
         GetDocsFailure (Maybe HsDocString, Map Int HsDocString)))
-> [Name]
-> m [Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
forall (m :: Type -> Type).
GhcMonad m =>
Name
-> m (Either
        GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
GHC.getDocs [Name]
names
  [MsgDoc]
sdocs <- (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
 -> m MsgDoc)
-> [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
-> m [MsgDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((GetDocsFailure -> m MsgDoc)
-> ((Maybe HsDocString, Map Int HsDocString) -> m MsgDoc)
-> Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)
-> m MsgDoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GetDocsFailure -> m MsgDoc
forall (m :: Type -> Type).
GhcMonad m =>
GetDocsFailure -> m MsgDoc
handleGetDocsFailure (MsgDoc -> m MsgDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MsgDoc -> m MsgDoc)
-> ((Maybe HsDocString, Map Int HsDocString) -> MsgDoc)
-> (Maybe HsDocString, Map Int HsDocString)
-> m MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HsDocString, Map Int HsDocString) -> MsgDoc
pprDocs)) [Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)]
e_docss
  let sdocs' :: MsgDoc
sdocs' = [MsgDoc] -> MsgDoc
vcat (MsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
intersperse (String -> MsgDoc
text String
"") [MsgDoc]
sdocs)
  PrintUnqualified
unqual <- m PrintUnqualified
forall (m :: Type -> Type). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (MsgDoc -> IO ()) -> MsgDoc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (MsgDoc -> String) -> MsgDoc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
unqual) MsgDoc
sdocs'

-- TODO: also print arg docs.
pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> MsgDoc
pprDocs (Maybe HsDocString
mb_decl_docs, Map Int HsDocString
_arg_docs) =
  MsgDoc -> (HsDocString -> MsgDoc) -> Maybe HsDocString -> MsgDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> MsgDoc
text String
"<has no documentation>")
    (String -> MsgDoc
text (String -> MsgDoc)
-> (HsDocString -> String) -> HsDocString -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> String
unpackHDS)
    Maybe HsDocString
mb_decl_docs

handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc
handleGetDocsFailure :: GetDocsFailure -> m MsgDoc
handleGetDocsFailure GetDocsFailure
no_docs = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  let msg :: String
msg = DynFlags -> GetDocsFailure -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags GetDocsFailure
no_docs
  GhcException -> m MsgDoc
forall a. GhcException -> a
throwGhcException (GhcException -> m MsgDoc) -> GhcException -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ case GetDocsFailure
no_docs of
    NameHasNoModule {} -> String -> GhcException
Sorry String
msg
    NoDocsInIface {} -> String -> GhcException
InstallationError String
msg
    GetDocsFailure
InteractiveName -> String -> GhcException
ProgramError String
msg

-----------------------------------------------------------------------------
-- :instances

instancesCmd :: String -> InputT GHCi ()
instancesCmd :: String -> InputT GHCi ()
instancesCmd String
"" =
  GhcException -> InputT GHCi ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax: ':instances <type-you-want-instances-for>'")
instancesCmd String
s = do
  (SourceError -> InputT GHCi ()) -> InputT GHCi () -> InputT GHCi ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (InputT GHCi () -> InputT GHCi ())
-> InputT GHCi () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- String -> InputT GHCi Type
forall (m :: Type -> Type). GhcMonad m => String -> m Type
GHC.parseInstanceHead String
s
    [ClsInst]
res <- Type -> InputT GHCi [ClsInst]
forall (m :: Type -> Type). GhcMonad m => Type -> m [ClsInst]
GHC.getInstancesForType Type
ty

    MsgDoc -> InputT GHCi ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> InputT GHCi ()) -> MsgDoc -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat ([MsgDoc] -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall a b. (a -> b) -> a -> b
$ (ClsInst -> MsgDoc) -> [ClsInst] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [ClsInst]
res

-----------------------------------------------------------------------------
-- :load, :add, :reload

-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
-- '-fdefer-type-errors' again if it has not been set before.
wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
wrapDeferTypeErrors :: m a -> m a
wrapDeferTypeErrors m a
load =
  m DynFlags -> (DynFlags -> m ()) -> (DynFlags -> m a) -> m a
forall (m :: Type -> Type) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket
    (do
      -- Force originalFlags to avoid leaking the associated HscEnv
      !DynFlags
originalFlags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
      m [InstalledUnitId] -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setProgramDynFlags (DynFlags -> m [InstalledUnitId])
-> DynFlags -> m [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$
         GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' GeneralFlag
Opt_DeferTypeErrors DynFlags
originalFlags
      DynFlags -> m DynFlags
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
originalFlags)
    (\DynFlags
originalFlags -> m [InstalledUnitId] -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setProgramDynFlags DynFlags
originalFlags)
    (\DynFlags
_ -> m a
load)

loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
loadModule :: [(String, Maybe Phase)] -> m SuccessFlag
loadModule [(String, Maybe Phase)]
fs = do
  (ActionStats
_, Either SomeException SuccessFlag
result) <- (SuccessFlag -> Maybe Integer)
-> m SuccessFlag
-> m (ActionStats, Either SomeException SuccessFlag)
forall (m :: Type -> Type) a.
GhciMonad m =>
(a -> Maybe Integer)
-> m a -> m (ActionStats, Either SomeException a)
runAndPrintStats (Maybe Integer -> SuccessFlag -> Maybe Integer
forall a b. a -> b -> a
const Maybe Integer
forall a. Maybe a
Nothing) ([(String, Maybe Phase)] -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[(String, Maybe Phase)] -> m SuccessFlag
loadModule' [(String, Maybe Phase)]
fs)
  (SomeException -> m SuccessFlag)
-> (SuccessFlag -> m SuccessFlag)
-> Either SomeException SuccessFlag
-> m SuccessFlag
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> m SuccessFlag)
-> (SomeException -> IO SuccessFlag)
-> SomeException
-> m SuccessFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO SuccessFlag
forall e a. Exception e => e -> IO a
Exception.throwIO) SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either SomeException SuccessFlag
result

-- | @:load@ command
loadModule_ :: GhciMonad m => [FilePath] -> m ()
loadModule_ :: [String] -> m ()
loadModule_ [String]
fs = m SuccessFlag -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m SuccessFlag -> m ()) -> m SuccessFlag -> m ()
forall a b. (a -> b) -> a -> b
$ [(String, Maybe Phase)] -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[(String, Maybe Phase)] -> m SuccessFlag
loadModule ([String] -> [Maybe Phase] -> [(String, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fs (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat Maybe Phase
forall a. Maybe a
Nothing))

loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
loadModuleDefer :: [String] -> m ()
loadModuleDefer = m () -> m ()
forall (m :: Type -> Type) a. GhcMonad m => m a -> m a
wrapDeferTypeErrors (m () -> m ()) -> ([String] -> m ()) -> [String] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
loadModule_

loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
loadModule' :: [(String, Maybe Phase)] -> m SuccessFlag
loadModule' [(String, Maybe Phase)]
files = do
  let ([String]
filenames, [Maybe Phase]
phases) = [(String, Maybe Phase)] -> ([String], [Maybe Phase])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, Maybe Phase)]
files
  [String]
exp_filenames <- (String -> m String) -> [String] -> m [String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath [String]
filenames
  let files' :: [(String, Maybe Phase)]
files' = [String] -> [Maybe Phase] -> [(String, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
exp_filenames [Maybe Phase]
phases
  [Target]
targets <- ((String, Maybe Phase) -> m Target)
-> [(String, Maybe Phase)] -> m [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Maybe Phase -> m Target)
-> (String, Maybe Phase) -> m Target
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
String -> Maybe Phase -> m Target
GHC.guessTarget) [(String, Maybe Phase)]
files'

  -- NOTE: we used to do the dependency anal first, so that if it
  -- fails we didn't throw away the current set of modules.  This would
  -- require some re-working of the GHC interface, so we'll leave it
  -- as a ToDo for now.

  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession

  -- Grab references to the currently loaded modules so that we can
  -- see if they leak.
  let !dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  LeakIndicators
leak_indicators <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciLeakCheck DynFlags
dflags
    then IO LeakIndicators -> m LeakIndicators
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO LeakIndicators -> m LeakIndicators)
-> IO LeakIndicators -> m LeakIndicators
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO LeakIndicators
getLeakIndicators HscEnv
hsc_env
    else LeakIndicators -> m LeakIndicators
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String -> LeakIndicators
forall a. String -> a
panic String
"no leak indicators")

  -- unload first
  Bool
_ <- m Bool
forall (m :: Type -> Type). GhcMonad m => m Bool
GHC.abandonAll
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearAllTargets

  [Target] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
  SuccessFlag
success <- Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
False LoadHowMuch
LoadAllTargets
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciLeakCheck DynFlags
dflags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> LeakIndicators -> IO ()
checkLeakIndicators DynFlags
dflags LeakIndicators
leak_indicators
  SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
success

-- | @:add@ command
addModule :: GhciMonad m => [FilePath] -> m ()
addModule :: [String] -> m ()
addModule [String]
files = do
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
revertCAFs -- always revert CAFs on load/add.
  [String]
files' <- (String -> m String) -> [String] -> m [String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath [String]
files
  [Target]
targets <- (String -> m Target) -> [String] -> m [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
m -> String -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
String -> Maybe Phase -> m Target
GHC.guessTarget String
m Maybe Phase
forall a. Maybe a
Nothing) [String]
files'
  [Target]
targets' <- (Target -> m Bool) -> [Target] -> m [Target]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Target -> m Bool
forall (m :: Type -> Type). GhcMonad m => Target -> m Bool
checkTarget [Target]
targets
  -- remove old targets with the same id; e.g. for :add *M
  (TargetId -> m ()) -> [TargetId] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TargetId -> m ()
forall (m :: Type -> Type). GhcMonad m => TargetId -> m ()
GHC.removeTarget [ TargetId
tid | Target TargetId
tid Bool
_ Maybe (StringBuffer, UTCTime)
_ <- [Target]
targets' ]
  (Target -> m ()) -> [Target] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Target -> m ()
forall (m :: Type -> Type). GhcMonad m => Target -> m ()
GHC.addTarget [Target]
targets'
  SuccessFlag
_ <- Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
False LoadHowMuch
LoadAllTargets
  () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  where
    checkTarget :: GHC.GhcMonad m => Target -> m Bool
    checkTarget :: Target -> m Bool
checkTarget (Target (TargetModule ModuleName
m) Bool
_ Maybe (StringBuffer, UTCTime)
_) = ModuleName -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Bool
checkTargetModule ModuleName
m
    checkTarget (Target (TargetFile String
f Maybe Phase
_) Bool
_ Maybe (StringBuffer, UTCTime)
_) = IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
checkTargetFile String
f

    checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool
    checkTargetModule :: ModuleName -> m Bool
checkTargetModule ModuleName
m = do
      HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
      FindResult
result <- IO FindResult -> m FindResult
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> m FindResult) -> IO FindResult -> m FindResult
forall a b. (a -> b) -> a -> b
$
        HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
Finder.findImportedModule HscEnv
hsc_env ModuleName
m (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (String -> FastString
fsLit String
"this"))
      case FindResult
result of
        Found ModLocation
_ Module
_ -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
        FindResult
_ -> (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found") m () -> m Bool -> m Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

    checkTargetFile :: String -> IO Bool
    checkTargetFile :: String -> IO Bool
checkTargetFile String
f = do
      Bool
exists <- (String -> IO Bool
doesFileExist String
f) :: IO Bool
      Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"File " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
      Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
exists

-- | @:unadd@ command
unAddModule :: GhciMonad m => [FilePath] -> m ()
unAddModule :: [String] -> m ()
unAddModule [String]
files = do
  [String]
files' <- (String -> m String) -> [String] -> m [String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath [String]
files
  [Target]
targets <- (String -> m Target) -> [String] -> m [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
m -> String -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
String -> Maybe Phase -> m Target
GHC.guessTarget String
m Maybe Phase
forall a. Maybe a
Nothing) [String]
files'
  (TargetId -> m ()) -> [TargetId] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TargetId -> m ()
forall (m :: Type -> Type). GhcMonad m => TargetId -> m ()
GHC.removeTarget [ TargetId
tid | Target TargetId
tid Bool
_ Maybe (StringBuffer, UTCTime)
_ <- [Target]
targets ]
  SuccessFlag
_ <- Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
False LoadHowMuch
LoadAllTargets
  () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-- | @:reload@ command
reloadModule :: GhciMonad m => String -> m ()
reloadModule :: String -> m ()
reloadModule String
m = m SuccessFlag -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m SuccessFlag -> m ()) -> m SuccessFlag -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
True LoadHowMuch
loadTargets
  where
    loadTargets :: LoadHowMuch
loadTargets | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
m    = LoadHowMuch
LoadAllTargets
                | Bool
otherwise = ModuleName -> LoadHowMuch
LoadUpTo (String -> ModuleName
GHC.mkModuleName String
m)

reloadModuleDefer :: GhciMonad m => String -> m ()
reloadModuleDefer :: String -> m ()
reloadModuleDefer = m () -> m ()
forall (m :: Type -> Type) a. GhcMonad m => m a -> m a
wrapDeferTypeErrors (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModule

-- | Load/compile targets and (optionally) collect module-info
--
-- This collects the necessary SrcSpan annotated type information (via
-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
-- and @:uses@ commands.
--
-- Meta-info collection is not enabled by default and needs to be
-- enabled explicitly via @:set +c@.  The reason is that collecting
-- the type-information for all sub-spans can be quite expensive, and
-- since those commands are designed to be used by editors and
-- tooling, it's useless to collect this data for normal GHCi
-- sessions.
doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo :: Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
retain_context LoadHowMuch
howmuch = do
  Bool
doCollectInfo <- GHCiOption -> m Bool
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m Bool
isOptionSet GHCiOption
CollectInfo

  Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoad Bool
retain_context LoadHowMuch
howmuch m SuccessFlag -> (SuccessFlag -> m SuccessFlag) -> m SuccessFlag
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SuccessFlag
Succeeded | Bool
doCollectInfo -> do
      [ModSummary]
mod_summaries <- ModuleGraph -> [ModSummary]
GHC.mgModSummaries (ModuleGraph -> [ModSummary]) -> m ModuleGraph -> m [ModSummary]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
getModuleGraph
      [ModuleName]
loaded <- (ModuleName -> m Bool) -> [ModuleName] -> m [ModuleName]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleName -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
GHC.ms_mod_name [ModSummary]
mod_summaries
      Map ModuleName ModInfo
v <- GHCiState -> Map ModuleName ModInfo
mod_infos (GHCiState -> Map ModuleName ModInfo)
-> m GHCiState -> m (Map ModuleName ModInfo)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      !Map ModuleName ModInfo
newInfos <- Map ModuleName ModInfo
-> [ModuleName] -> m (Map ModuleName ModInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> [ModuleName] -> m (Map ModuleName ModInfo)
collectInfo Map ModuleName ModInfo
v [ModuleName]
loaded
      (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { mod_infos :: Map ModuleName ModInfo
mod_infos = Map ModuleName ModInfo
newInfos })
      SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
Succeeded
    SuccessFlag
flag -> SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
flag

doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
doLoad :: Bool -> LoadHowMuch -> m SuccessFlag
doLoad Bool
retain_context LoadHowMuch
howmuch = do
  -- turn off breakpoints before we load: we can't turn them off later, because
  -- the ModBreaks will have gone away.
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardActiveBreakPoints

  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
resetLastErrorLocations
  -- Enable buffering stdout and stderr as we're compiling. Keeping these
  -- handles unbuffered will just slow the compilation down, especially when
  -- compiling in parallel.
  m () -> (() -> m ()) -> (() -> m SuccessFlag) -> m SuccessFlag
forall (m :: Type -> Type) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
                        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering)
           (\()
_ ->
            IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
                        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
NoBuffering) ((() -> m SuccessFlag) -> m SuccessFlag)
-> (() -> m SuccessFlag) -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
      SuccessFlag
ok <- m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
m SuccessFlag -> m SuccessFlag
trySuccess (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
howmuch
      SuccessFlag -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
SuccessFlag -> Bool -> m ()
afterLoad SuccessFlag
ok Bool
retain_context
      SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
ok


afterLoad
  :: GhciMonad m
  => SuccessFlag
  -> Bool   -- keep the remembered_ctx, as far as possible (:reload)
  -> m ()
afterLoad :: SuccessFlag -> Bool -> m ()
afterLoad SuccessFlag
ok Bool
retain_context = do
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
revertCAFs  -- always revert CAFs on load.
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardTickArrays
  [ModSummary]
loaded_mods <- m [ModSummary]
forall (m :: Type -> Type). GhcMonad m => m [ModSummary]
getLoadedModules
  SuccessFlag -> [ModSummary] -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
SuccessFlag -> [ModSummary] -> m ()
modulesLoadedMsg SuccessFlag
ok [ModSummary]
loaded_mods
  Bool -> [ModSummary] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [ModSummary] -> m ()
setContextAfterLoad Bool
retain_context [ModSummary]
loaded_mods

setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()
setContextAfterLoad :: Bool -> [ModSummary] -> m ()
setContextAfterLoad Bool
keep_ctxt [] = do
  Bool -> [InteractiveImport] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [InteractiveImport] -> m ()
setContextKeepingPackageModules Bool
keep_ctxt []
setContextAfterLoad Bool
keep_ctxt [ModSummary]
ms = do
  -- load a target if one is available, otherwise load the topmost module.
  [Target]
targets <- m [Target]
forall (m :: Type -> Type). GhcMonad m => m [Target]
GHC.getTargets
  case [ ModSummary
m | Just ModSummary
m <- (Target -> Maybe ModSummary) -> [Target] -> [Maybe ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ([ModSummary] -> Target -> Maybe ModSummary
findTarget [ModSummary]
ms) [Target]
targets ] of
        []    ->
          let graph :: ModuleGraph
graph = [ModSummary] -> ModuleGraph
GHC.mkModuleGraph [ModSummary]
ms
              graph' :: [ModSummary]
graph' = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs (Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ModuleGraph
graph Maybe ModuleName
forall a. Maybe a
Nothing)
          in ModSummary -> m ()
forall (m :: Type -> Type). GhciMonad m => ModSummary -> m ()
load_this ([ModSummary] -> ModSummary
forall a. [a] -> a
last [ModSummary]
graph')
        (ModSummary
m:[ModSummary]
_) ->
          ModSummary -> m ()
forall (m :: Type -> Type). GhciMonad m => ModSummary -> m ()
load_this ModSummary
m
 where
   findTarget :: [ModSummary] -> Target -> Maybe ModSummary
findTarget [ModSummary]
mds Target
t
    = case (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModSummary -> Target -> Bool
`matches` Target
t) [ModSummary]
mds of
        []    -> Maybe ModSummary
forall a. Maybe a
Nothing
        (ModSummary
m:[ModSummary]
_) -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
m

   ModSummary
summary matches :: ModSummary -> Target -> Bool
`matches` Target (TargetModule ModuleName
m) Bool
_ Maybe (StringBuffer, UTCTime)
_
        = ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
summary ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m
   ModSummary
summary `matches` Target (TargetFile String
f Maybe Phase
_) Bool
_ Maybe (StringBuffer, UTCTime)
_
        | Just String
f' <- ModLocation -> Maybe String
GHC.ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
summary)   = String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f'
   ModSummary
_ `matches` Target
_
        = Bool
False

   load_this :: ModSummary -> m ()
load_this ModSummary
summary | Module
m <- ModSummary -> Module
GHC.ms_mod ModSummary
summary = do
        Bool
is_interp <- Module -> m Bool
forall (m :: Type -> Type). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
m
        DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
        let star_ok :: Bool
star_ok = Bool
is_interp Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
safeLanguageOn DynFlags
dflags)
              -- We import the module with a * iff
              --   - it is interpreted, and
              --   - -XSafe is off (it doesn't allow *-imports)
        let new_ctx :: [InteractiveImport]
new_ctx | Bool
star_ok   = [ModuleName -> InteractiveImport
mkIIModule (Module -> ModuleName
GHC.moduleName Module
m)]
                    | Bool
otherwise = [ModuleName -> InteractiveImport
mkIIDecl   (Module -> ModuleName
GHC.moduleName Module
m)]
        Bool -> [InteractiveImport] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [InteractiveImport] -> m ()
setContextKeepingPackageModules Bool
keep_ctxt [InteractiveImport]
new_ctx


-- | Keep any package modules (except Prelude) when changing the context.
setContextKeepingPackageModules
  :: GhciMonad m
  => Bool                 -- True  <=> keep all of remembered_ctx
                          -- False <=> just keep package imports
  -> [InteractiveImport]  -- new context
  -> m ()
setContextKeepingPackageModules :: Bool -> [InteractiveImport] -> m ()
setContextKeepingPackageModules Bool
keep_ctx [InteractiveImport]
trans_ctx = do

  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let rem_ctx :: [InteractiveImport]
rem_ctx = GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st
  [InteractiveImport]
new_rem_ctx <- if Bool
keep_ctx then [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InteractiveImport]
rem_ctx
                             else [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type).
GhcMonad m =>
[InteractiveImport] -> m [InteractiveImport]
keepPackageImports [InteractiveImport]
rem_ctx
  GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{ remembered_ctx :: [InteractiveImport]
remembered_ctx = [InteractiveImport]
new_rem_ctx,
                   transient_ctx :: [InteractiveImport]
transient_ctx  = [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
filterSubsumed [InteractiveImport]
new_rem_ctx [InteractiveImport]
trans_ctx }
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
setGHCContextFromGHCiState

-- | Filters a list of 'InteractiveImport', clearing out any home package
-- imports so only imports from external packages are preserved.  ('IIModule'
-- counts as a home package import, because we are only able to bring a
-- full top-level into scope when the source is available.)
keepPackageImports
  :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]
keepPackageImports :: [InteractiveImport] -> m [InteractiveImport]
keepPackageImports = (InteractiveImport -> m Bool)
-> [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM InteractiveImport -> m Bool
forall (m :: Type -> Type).
GhcMonad m =>
InteractiveImport -> m Bool
is_pkg_import
  where
     is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
     is_pkg_import :: InteractiveImport -> m Bool
is_pkg_import (IIModule ModuleName
_) = Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
     is_pkg_import (IIDecl ImportDecl GhcPs
d)
         = do Either SomeException Module
e <- m Module -> m (Either SomeException Module)
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
m a -> m (Either e a)
gtry (m Module -> m (Either SomeException Module))
-> m Module -> m (Either SomeException Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
mod_name ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (Maybe StringLiteral -> Maybe FastString)
-> Maybe StringLiteral -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
d)
              case Either SomeException Module
e :: Either SomeException Module of
                Left SomeException
_  -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
                Right Module
m -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> Bool
not (Module -> Bool
isHomeModule Module
m))
        where
          mod_name :: SrcSpanLess (Located ModuleName)
mod_name = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d)


modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
modulesLoadedMsg :: SuccessFlag -> [ModSummary] -> m ()
modulesLoadedMsg SuccessFlag
ok [ModSummary]
mods = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  PrintUnqualified
unqual <- m PrintUnqualified
forall (m :: Type -> Type). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual

  MsgDoc
msg <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ShowLoadedModules DynFlags
dflags
         then do
               [MsgDoc]
mod_names <- (ModSummary -> m MsgDoc) -> [ModSummary] -> m [MsgDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModSummary -> m MsgDoc
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m MsgDoc
mod_name [ModSummary]
mods
               let mod_commas :: MsgDoc
mod_commas
                     | [ModSummary] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [ModSummary]
mods = String -> MsgDoc
text String
"none."
                     | Bool
otherwise = [MsgDoc] -> MsgDoc
hsep (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
comma [MsgDoc]
mod_names) MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
"."
               MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> m MsgDoc) -> MsgDoc -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc
status MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
", modules loaded:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
mod_commas
         else do
               MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> m MsgDoc) -> MsgDoc -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc
status MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
","
                    MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc -> MsgDoc
speakNOf ([ModSummary] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ModSummary]
mods) (String -> MsgDoc
text String
"module") MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
"loaded."

  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
     IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
unqual MsgDoc
msg
  where
    status :: MsgDoc
status = case SuccessFlag
ok of
                  SuccessFlag
Failed    -> String -> MsgDoc
text String
"Failed"
                  SuccessFlag
Succeeded -> String -> MsgDoc
text String
"Ok"

    mod_name :: ModSummary -> m MsgDoc
mod_name ModSummary
mod = do
        Bool
is_interpreted <- ModSummary -> m Bool
forall (f :: Type -> Type). GhcMonad f => ModSummary -> f Bool
GHC.moduleIsBootOrNotObjectLinkable ModSummary
mod
        MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> m MsgDoc) -> MsgDoc -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ if Bool
is_interpreted
                 then Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (ModSummary -> Module
GHC.ms_mod ModSummary
mod)
                 else Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (ModSummary -> Module
GHC.ms_mod ModSummary
mod)
                      MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
parens (String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msObjFilePath ModSummary
mod)
                      -- Fix #9887

-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
-- and printing 'throwE' strings to 'stderr'
runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
runExceptGhcMonad :: ExceptT MsgDoc m () -> m ()
runExceptGhcMonad ExceptT MsgDoc m ()
act = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                        (MsgDoc -> m ()) -> (() -> m ()) -> Either MsgDoc () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MsgDoc -> m ()
forall (m :: Type -> Type).
(HasDynFlags m, MonadIO m) =>
MsgDoc -> m ()
handleErr () -> m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either MsgDoc () -> m ()) -> m (Either MsgDoc ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                        ExceptT MsgDoc m () -> m (Either MsgDoc ())
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT MsgDoc m ()
act
  where
    handleErr :: MsgDoc -> m ()
handleErr MsgDoc
sdoc = do
        DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (MsgDoc -> IO ()) -> MsgDoc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (MsgDoc -> String) -> MsgDoc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
alwaysQualify (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ MsgDoc
sdoc

-- | Inverse of 'runExceptT' for \"pure\" computations
-- (c.f. 'except' for 'Except')
exceptT :: Applicative m => Either e a -> ExceptT e m a
exceptT :: Either e a -> ExceptT e m a
exceptT = m (Either e a) -> ExceptT e m a
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> (Either e a -> m (Either e a)) -> Either e a -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

makeHDL'
  :: forall backend
   . Backend backend
  => Proxy backend
  -> IORef ClashOpts
  -> [FilePath]
  -> InputT GHCi ()
makeHDL' :: Proxy backend -> IORef ClashOpts -> [String] -> InputT GHCi ()
makeHDL' Proxy backend
backend IORef ClashOpts
opts [String]
lst = [String] -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
go ([String] -> InputT GHCi ())
-> InputT GHCi [String] -> InputT GHCi ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< case [String]
lst of
  srcs :: [String]
srcs@(String
_:[String]
_) -> [String] -> InputT GHCi [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [String]
srcs
  []         -> do
    ModuleGraph
modGraph <- InputT GHCi ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
    let sortedGraph :: [SCC ModSummary]
sortedGraph = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
False ModuleGraph
modGraph Maybe ModuleName
forall a. Maybe a
Nothing
    [String] -> InputT GHCi [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([String] -> InputT GHCi [String])
-> [String] -> InputT GHCi [String]
forall a b. (a -> b) -> a -> b
$ case ([SCC ModSummary] -> [SCC ModSummary]
forall a. [a] -> [a]
reverse [SCC ModSummary]
sortedGraph) of
      ((AcyclicSCC ModSummary
top) : [SCC ModSummary]
_) -> Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ (ModLocation -> Maybe String
GHC.ml_hs_file (ModLocation -> Maybe String)
-> (ModSummary -> ModLocation) -> ModSummary -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
GHC.ms_location) ModSummary
top
      [SCC ModSummary]
_                      -> []
 where
  go :: [String] -> m ()
go [String]
srcs = do
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    DynFlags -> [String] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
DynFlags -> [String] -> m ()
goX DynFlags
dflags [String]
srcs m () -> m () -> m ()
forall (m :: Type -> Type) a b.
ExceptionMonad m =>
m a -> m b -> m a
`gfinally` DynFlags -> m ()
forall (m :: Type -> Type). GhciMonad m => DynFlags -> m ()
recover DynFlags
dflags

  goX :: DynFlags -> [String] -> m ()
goX DynFlags
dflags [String]
srcs = do
    -- Issue #439 step 1
    (DynFlags
dflagsX,[Located String]
_,[Warn]
_) <- DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags
                       [ SrcSpanLess (Located String) -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located String)
"-fobject-code"   -- For #439
                       , SrcSpanLess (Located String) -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located String)
"-fforce-recomp"  -- Actually compile to object-code
                       , SrcSpanLess (Located String) -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located String)
"-keep-tmp-files" -- To prevent linker errors from
                                                 -- multiple calls to :hdl command
                       ]
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflagsX
    String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModule String
""
    -- Issue #439 step 2
    -- Unload any object files
    -- This fixes: https://github.com/clash-lang/clash-compiler/issues/439#issuecomment-522015868
    HscEnv
env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> [Linkable] -> IO ()
unload HscEnv
env [])
    -- Finally generate the HDL
    Proxy backend -> Ghc () -> IORef ClashOpts -> [String] -> m ()
forall backend (m :: Type -> Type).
(GhcMonad m, Backend backend) =>
Proxy backend -> Ghc () -> IORef ClashOpts -> [String] -> m ()
makeHDL Proxy backend
backend (() -> Ghc ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()) IORef ClashOpts
opts [String]
srcs

  recover :: DynFlags -> m ()
recover DynFlags
dflags = do
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags
    String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
reloadModule String
""

makeHDL
  :: forall backend m
   . (GHC.GhcMonad m, Backend backend)
  => Proxy backend
  -> GHC.Ghc ()
  -> IORef ClashOpts
  -> [FilePath]
  -> m ()
makeHDL :: Proxy backend -> Ghc () -> IORef ClashOpts -> [String] -> m ()
makeHDL Proxy backend
Proxy Ghc ()
startAction IORef ClashOpts
optsRef [String]
srcs = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do UTCTime
startTime <- IO UTCTime
Clock.getCurrentTime
              ClashOpts
opts0  <- IORef ClashOpts -> IO ClashOpts
forall a. IORef a -> IO a
readIORef IORef ClashOpts
optsRef
              let opts1 :: ClashOpts
opts1  = ClashOpts
opts0 { opt_color :: OverridingBool
opt_color = DynFlags -> OverridingBool
useColor DynFlags
dflags }
              let iw :: Int
iw     = ClashOpts -> Int
opt_intWidth ClashOpts
opts1
                  hdl :: HDL
hdl    = backend -> HDL
forall state. Backend state => state -> HDL
hdlKind backend
backend
                  -- determine whether `-outputdir` was used
                  outputDir :: Maybe String
outputDir = do String
odir <- DynFlags -> Maybe String
objectDir DynFlags
dflags
                                 String
hidir <- DynFlags -> Maybe String
hiDir DynFlags
dflags
                                 String
sdir <- DynFlags -> Maybe String
stubDir DynFlags
dflags
                                 String
ddir <- DynFlags -> Maybe String
dumpDir DynFlags
dflags
                                 if (String -> Bool) -> [String] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
odir) [String
hidir,String
sdir,String
ddir]
                                    then String -> Maybe String
forall a. a -> Maybe a
Just String
odir
                                    else Maybe String
forall a. Maybe a
Nothing
                  idirs :: [String]
idirs = DynFlags -> [String]
importPaths DynFlags
dflags
                  opts2 :: ClashOpts
opts2 = ClashOpts
opts1 { opt_hdlDir :: Maybe String
opt_hdlDir = Maybe String
-> (String -> Maybe String) -> Maybe String -> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
outputDir String -> Maybe String
forall a. a -> Maybe a
Just (ClashOpts -> Maybe String
opt_hdlDir ClashOpts
opts1)
                                , opt_importPaths :: [String]
opt_importPaths = [String]
idirs}
                  backend :: backend
backend = ClashOpts -> backend
forall state. Backend state => ClashOpts -> state
initBackend @backend ClashOpts
opts2

              DynFlags -> IO ()
checkMonoLocalBinds DynFlags
dflags
              ClashOpts -> [String] -> IO ()
forall (t :: Type -> Type).
Foldable t =>
ClashOpts -> t String -> IO ()
checkImportDirs ClashOpts
opts0 [String]
idirs

              [String]
primDirs_ <- backend -> IO [String]
forall state. Backend state => state -> IO [String]
primDirs backend
backend

              [String] -> (String -> IO ()) -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
srcs ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
src -> do
                -- Generate bindings:
                let dbs :: [String]
dbs = [String] -> [String]
forall a. [a] -> [a]
reverse [String
p | PackageDB (PkgConfFile String
p) <- DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
dflags]
                (ClashEnv
clashEnv, ClashDesign
clashDesign) <- ClashOpts
-> Ghc ()
-> [String]
-> [String]
-> [String]
-> HDL
-> String
-> Maybe DynFlags
-> IO (ClashEnv, ClashDesign)
generateBindings ClashOpts
opts2 Ghc ()
startAction [String]
primDirs_ [String]
idirs [String]
dbs HDL
hdl String
src (DynFlags -> Maybe DynFlags
forall a. a -> Maybe a
Just DynFlags
dflags)

                let getMain :: String -> IO (TopEntityT, [TopEntityT])
getMain = HasCallStack =>
String -> ClashDesign -> String -> IO (TopEntityT, [TopEntityT])
String -> ClashDesign -> String -> IO (TopEntityT, [TopEntityT])
getMainTopEntity String
src ClashDesign
clashDesign
                Maybe (TopEntityT, [TopEntityT])
mainTopEntity <- (String -> IO (TopEntityT, [TopEntityT]))
-> Maybe String -> IO (Maybe (TopEntityT, [TopEntityT]))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (TopEntityT, [TopEntityT])
getMain (DynFlags -> Maybe String
GHC.mainFunIs DynFlags
dflags)
                UTCTime
prepTime <- UTCTime
startTime UTCTime -> BindingMap -> BindingMap
forall a b. NFData a => a -> b -> b
`deepseq` ClashDesign -> BindingMap
designBindings ClashDesign
clashDesign BindingMap -> TyConMap -> TyConMap
forall a b. NFData a => a -> b -> b
`deepseq` ClashEnv -> TyConMap
envTyConMap ClashEnv
clashEnv TyConMap -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
                let prepStartDiff :: String
prepStartDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
prepTime UTCTime
startTime
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC+Clash: Loading modules cumulatively took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prepStartDiff

                -- Generate HDL:
                ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> Maybe (TopEntityT, [TopEntityT])
-> UTCTime
-> IO ()
forall backend.
Backend backend =>
ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> Maybe (TopEntityT, [TopEntityT])
-> UTCTime
-> IO ()
Clash.Driver.generateHDL
                  ClashEnv
clashEnv
                  ClashDesign
clashDesign
                  (backend -> Maybe backend
forall a. a -> Maybe a
Just backend
backend)
                  (Int
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
ghcTypeToHWType Int
iw)
                  Evaluator
ghcEvaluator
                  Evaluator
evaluator
                  Maybe (TopEntityT, [TopEntityT])
mainTopEntity
                  UTCTime
startTime

makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
makeVHDL :: IORef ClashOpts -> [String] -> InputT GHCi ()
makeVHDL = Proxy VHDLState -> IORef ClashOpts -> [String] -> InputT GHCi ()
forall backend.
Backend backend =>
Proxy backend -> IORef ClashOpts -> [String] -> InputT GHCi ()
makeHDL' (Proxy VHDLState
forall k (t :: k). Proxy t
Proxy @VHDLState)

makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
makeVerilog :: IORef ClashOpts -> [String] -> InputT GHCi ()
makeVerilog = Proxy VerilogState -> IORef ClashOpts -> [String] -> InputT GHCi ()
forall backend.
Backend backend =>
Proxy backend -> IORef ClashOpts -> [String] -> InputT GHCi ()
makeHDL' (Proxy VerilogState
forall k (t :: k). Proxy t
Proxy @VerilogState)

makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
makeSystemVerilog :: IORef ClashOpts -> [String] -> InputT GHCi ()
makeSystemVerilog = Proxy SystemVerilogState
-> IORef ClashOpts -> [String] -> InputT GHCi ()
forall backend.
Backend backend =>
Proxy backend -> IORef ClashOpts -> [String] -> InputT GHCi ()
makeHDL' (Proxy SystemVerilogState
forall k (t :: k). Proxy t
Proxy @SystemVerilogState)

-----------------------------------------------------------------------------
-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.

typeOfExpr :: GHC.GhcMonad m => String -> m ()
typeOfExpr :: String -> m ()
typeOfExpr String
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let (TcRnExprMode
mode, String
expr_str) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
str of
          (String
"+d", String
rest) -> (TcRnExprMode
GHC.TM_Default, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest)
          (String
"+v", String
rest) -> (TcRnExprMode
GHC.TM_NoInst,  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest)
          (String, String)
_            -> (TcRnExprMode
GHC.TM_Inst,    String
str)
    Type
ty <- TcRnExprMode -> String -> m Type
forall (m :: Type -> Type).
GhcMonad m =>
TcRnExprMode -> String -> m Type
GHC.exprType TcRnExprMode
mode String
expr_str
    MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
expr_str, Int -> MsgDoc -> MsgDoc
nest Int
2 (MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
pprTypeForUser Type
ty)]

-----------------------------------------------------------------------------
-- | @:type-at@ command

typeAtCmd :: GhciMonad m => String -> m ()
typeAtCmd :: String -> m ()
typeAtCmd String
str = ExceptT MsgDoc m () -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ExceptT MsgDoc m () -> m ()
runExceptGhcMonad (ExceptT MsgDoc m () -> m ()) -> ExceptT MsgDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',String
sample) <- Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either MsgDoc (RealSrcSpan, String)
 -> ExceptT MsgDoc m (RealSrcSpan, String))
-> Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall a b. (a -> b) -> a -> b
$ String -> Either MsgDoc (RealSrcSpan, String)
parseSpanArg String
str
    Map ModuleName ModInfo
infos      <- m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Map ModuleName ModInfo)
 -> ExceptT MsgDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall a b. (a -> b) -> a -> b
$ GHCiState -> Map ModuleName ModInfo
mod_infos (GHCiState -> Map ModuleName ModInfo)
-> m GHCiState -> m (Map ModuleName ModInfo)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    (ModInfo
info, Type
ty) <- Map ModuleName ModInfo
-> RealSrcSpan -> String -> ExceptT MsgDoc m (ModInfo, Type)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> String -> ExceptT MsgDoc m (ModInfo, Type)
findType Map ModuleName ModInfo
infos RealSrcSpan
span' String
sample
    m () -> ExceptT MsgDoc m ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT MsgDoc m ()) -> m () -> ExceptT MsgDoc m ()
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> MsgDoc -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ModuleInfo -> MsgDoc -> m ()
printForUserModInfo (ModInfo -> ModuleInfo
modinfoInfo ModInfo
info)
                               ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
sample,Int -> MsgDoc -> MsgDoc
nest Int
2 (MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty)])

-----------------------------------------------------------------------------
-- | @:uses@ command

usesCmd :: GhciMonad m => String -> m ()
usesCmd :: String -> m ()
usesCmd String
str = ExceptT MsgDoc m () -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ExceptT MsgDoc m () -> m ()
runExceptGhcMonad (ExceptT MsgDoc m () -> m ()) -> ExceptT MsgDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',String
sample) <- Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either MsgDoc (RealSrcSpan, String)
 -> ExceptT MsgDoc m (RealSrcSpan, String))
-> Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall a b. (a -> b) -> a -> b
$ String -> Either MsgDoc (RealSrcSpan, String)
parseSpanArg String
str
    Map ModuleName ModInfo
infos  <- m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Map ModuleName ModInfo)
 -> ExceptT MsgDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall a b. (a -> b) -> a -> b
$ GHCiState -> Map ModuleName ModInfo
mod_infos (GHCiState -> Map ModuleName ModInfo)
-> m GHCiState -> m (Map ModuleName ModInfo)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    [SrcSpan]
uses   <- Map ModuleName ModInfo
-> RealSrcSpan -> String -> ExceptT MsgDoc m [SrcSpan]
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> String -> ExceptT MsgDoc m [SrcSpan]
findNameUses Map ModuleName ModInfo
infos RealSrcSpan
span' String
sample
    [SrcSpan]
-> (SrcSpan -> ExceptT MsgDoc m ()) -> ExceptT MsgDoc m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SrcSpan]
uses (IO () -> ExceptT MsgDoc m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT MsgDoc m ())
-> (SrcSpan -> IO ()) -> SrcSpan -> ExceptT MsgDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (SrcSpan -> String) -> SrcSpan -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String
showSrcSpan)

-----------------------------------------------------------------------------
-- | @:loc-at@ command

locAtCmd :: GhciMonad m => String -> m ()
locAtCmd :: String -> m ()
locAtCmd String
str = ExceptT MsgDoc m () -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ExceptT MsgDoc m () -> m ()
runExceptGhcMonad (ExceptT MsgDoc m () -> m ()) -> ExceptT MsgDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',String
sample) <- Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either MsgDoc (RealSrcSpan, String)
 -> ExceptT MsgDoc m (RealSrcSpan, String))
-> Either MsgDoc (RealSrcSpan, String)
-> ExceptT MsgDoc m (RealSrcSpan, String)
forall a b. (a -> b) -> a -> b
$ String -> Either MsgDoc (RealSrcSpan, String)
parseSpanArg String
str
    Map ModuleName ModInfo
infos    <- m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Map ModuleName ModInfo)
 -> ExceptT MsgDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall a b. (a -> b) -> a -> b
$ GHCiState -> Map ModuleName ModInfo
mod_infos (GHCiState -> Map ModuleName ModInfo)
-> m GHCiState -> m (Map ModuleName ModInfo)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    (ModInfo
_,Name
_,SrcSpan
sp) <- Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT MsgDoc m (ModInfo, Name, SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT MsgDoc m (ModInfo, Name, SrcSpan)
findLoc Map ModuleName ModInfo
infos RealSrcSpan
span' String
sample
    IO () -> ExceptT MsgDoc m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT MsgDoc m ())
-> (SrcSpan -> IO ()) -> SrcSpan -> ExceptT MsgDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (SrcSpan -> String) -> SrcSpan -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String
showSrcSpan (SrcSpan -> ExceptT MsgDoc m ()) -> SrcSpan -> ExceptT MsgDoc m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan
sp

-----------------------------------------------------------------------------
-- | @:all-types@ command

allTypesCmd :: GhciMonad m => String -> m ()
allTypesCmd :: String -> m ()
allTypesCmd String
_ = ExceptT MsgDoc m () -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ExceptT MsgDoc m () -> m ()
runExceptGhcMonad (ExceptT MsgDoc m () -> m ()) -> ExceptT MsgDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Map ModuleName ModInfo
infos <- m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Map ModuleName ModInfo)
 -> ExceptT MsgDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT MsgDoc m (Map ModuleName ModInfo)
forall a b. (a -> b) -> a -> b
$ GHCiState -> Map ModuleName ModInfo
mod_infos (GHCiState -> Map ModuleName ModInfo)
-> m GHCiState -> m (Map ModuleName ModInfo)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    [ModInfo]
-> (ModInfo -> ExceptT MsgDoc m ()) -> ExceptT MsgDoc m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ModuleName ModInfo -> [ModInfo]
forall k a. Map k a -> [a]
M.elems Map ModuleName ModInfo
infos) ((ModInfo -> ExceptT MsgDoc m ()) -> ExceptT MsgDoc m ())
-> (ModInfo -> ExceptT MsgDoc m ()) -> ExceptT MsgDoc m ()
forall a b. (a -> b) -> a -> b
$ \ModInfo
mi ->
        [SpanInfo]
-> (SpanInfo -> ExceptT MsgDoc m ()) -> ExceptT MsgDoc m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ModInfo -> [SpanInfo]
modinfoSpans ModInfo
mi) (m () -> ExceptT MsgDoc m ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT MsgDoc m ())
-> (SpanInfo -> m ()) -> SpanInfo -> ExceptT MsgDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> m ()
forall (m :: Type -> Type).
(HasDynFlags m, MonadIO m) =>
SpanInfo -> m ()
printSpan)
  where
    printSpan :: SpanInfo -> m ()
printSpan SpanInfo
span'
      | Just Type
ty <- SpanInfo -> Maybe Type
spaninfoType SpanInfo
span' = do
        DynFlags
df <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
        let tyInfo :: String
tyInfo = [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                     DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
df PrintUnqualified
alwaysQualify (Type -> MsgDoc
pprTypeForUser Type
ty)
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
            RealSrcSpan -> String
showRealSrcSpan (SpanInfo -> RealSrcSpan
spaninfoSrcSpan SpanInfo
span') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyInfo
      | Bool
otherwise = () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-----------------------------------------------------------------------------
-- Helpers for locAtCmd/typeAtCmd/usesCmd

-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
parseSpanArg :: String -> Either MsgDoc (RealSrcSpan, String)
parseSpanArg String
s = do
    (String
fp,String
s0) <- String -> Either MsgDoc (String, String)
readAsString (String -> String
skipWs String
s)
    String
s0'     <- String -> Either MsgDoc String
skipWs1 String
s0
    (Int
sl,String
s1) <- String -> Either MsgDoc (Int, String)
readAsInt String
s0'
    String
s1'     <- String -> Either MsgDoc String
skipWs1 String
s1
    (Int
sc,String
s2) <- String -> Either MsgDoc (Int, String)
readAsInt String
s1'
    String
s2'     <- String -> Either MsgDoc String
skipWs1 String
s2
    (Int
el,String
s3) <- String -> Either MsgDoc (Int, String)
readAsInt String
s2'
    String
s3'     <- String -> Either MsgDoc String
skipWs1 String
s3
    (Int
ec,String
s4) <- String -> Either MsgDoc (Int, String)
readAsInt String
s3'

    String
trailer <- case String
s4 of
        [] -> String -> Either MsgDoc String
forall a b. b -> Either a b
Right String
""
        String
_  -> String -> Either MsgDoc String
skipWs1 String
s4

    let fs :: FastString
fs    = String -> FastString
mkFastString String
fp
        span' :: RealSrcSpan
span' = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fs Int
sl Int
sc)
                              -- End column of RealSrcSpan is the column
                              -- after the end of the span.
                              (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fs Int
el (Int
ec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

    (RealSrcSpan, String) -> Either MsgDoc (RealSrcSpan, String)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RealSrcSpan
span',String
trailer)
  where
    readAsInt :: String -> Either SDoc (Int,String)
    readAsInt :: String -> Either MsgDoc (Int, String)
readAsInt String
"" = MsgDoc -> Either MsgDoc (Int, String)
forall a b. a -> Either a b
Left MsgDoc
"Premature end of string while expecting Int"
    readAsInt String
s0 = case ReadS Int
forall a. Read a => ReadS a
reads String
s0 of
        [(Int, String)
s_rest] -> (Int, String) -> Either MsgDoc (Int, String)
forall a b. b -> Either a b
Right (Int, String)
s_rest
        [(Int, String)]
_        -> MsgDoc -> Either MsgDoc (Int, String)
forall a b. a -> Either a b
Left (MsgDoc
"Couldn't read" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (String -> String
forall a. Show a => a -> String
show String
s0) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
"as Int")

    readAsString :: String -> Either SDoc (String,String)
    readAsString :: String -> Either MsgDoc (String, String)
readAsString String
s0
      | Char
'"':String
_ <- String
s0 = case ReadS String
forall a. Read a => ReadS a
reads String
s0 of
          [(String, String)
s_rest] -> (String, String) -> Either MsgDoc (String, String)
forall a b. b -> Either a b
Right (String, String)
s_rest
          [(String, String)]
_        -> Either MsgDoc (String, String)
forall b. Either MsgDoc b
leftRes
      | s_rest :: (String, String)
s_rest@(Char
_:String
_,String
_) <- String -> (String, String)
breakWs String
s0 = (String, String) -> Either MsgDoc (String, String)
forall a b. b -> Either a b
Right (String, String)
s_rest
      | Bool
otherwise = Either MsgDoc (String, String)
forall b. Either MsgDoc b
leftRes
      where
        leftRes :: Either MsgDoc b
leftRes = MsgDoc -> Either MsgDoc b
forall a b. a -> Either a b
Left (MsgDoc
"Couldn't read" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (String -> String
forall a. Show a => a -> String
show String
s0) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
"as String")

    skipWs1 :: String -> Either SDoc String
    skipWs1 :: String -> Either MsgDoc String
skipWs1 (Char
c:String
cs) | Char -> Bool
isWs Char
c = String -> Either MsgDoc String
forall a b. b -> Either a b
Right (String -> String
skipWs String
cs)
    skipWs1 String
s0 = MsgDoc -> Either MsgDoc String
forall a b. a -> Either a b
Left (MsgDoc
"Expected whitespace in" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (String -> String
forall a. Show a => a -> String
show String
s0))

    isWs :: Char -> Bool
isWs    = (Char -> String -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Char
' ',Char
'\t'])
    skipWs :: String -> String
skipWs  = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isWs
    breakWs :: String -> (String, String)
breakWs = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isWs


-- | Pretty-print \"real\" 'SrcSpan's as
-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
-- while simply unpacking 'UnhelpfulSpan's
showSrcSpan :: SrcSpan -> String
showSrcSpan :: SrcSpan -> String
showSrcSpan (UnhelpfulSpan FastString
s)  = FastString -> String
unpackFS FastString
s
showSrcSpan (RealSrcSpan RealSrcSpan
spn)  = RealSrcSpan -> String
showRealSrcSpan RealSrcSpan
spn

-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
showRealSrcSpan :: RealSrcSpan -> String
showRealSrcSpan :: RealSrcSpan -> String
showRealSrcSpan RealSrcSpan
spn = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ String
fp, String
":(", Int -> String
forall a. Show a => a -> String
show Int
sl, String
",", Int -> String
forall a. Show a => a -> String
show Int
sc
                             , String
")-(", Int -> String
forall a. Show a => a -> String
show Int
el, String
",", Int -> String
forall a. Show a => a -> String
show Int
ec, String
")"
                             ]
  where
    fp :: String
fp = FastString -> String
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
spn)
    sl :: Int
sl = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
spn
    sc :: Int
sc = RealSrcSpan -> Int
srcSpanStartCol  RealSrcSpan
spn
    el :: Int
el = RealSrcSpan -> Int
srcSpanEndLine   RealSrcSpan
spn
    -- The end column is the column after the end of the span see the
    -- RealSrcSpan module
    ec :: Int
ec = let ec' :: Int
ec' = RealSrcSpan -> Int
srcSpanEndCol    RealSrcSpan
spn in if Int
ec' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
ec' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-----------------------------------------------------------------------------
-- | @:kind@ command

kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()
kindOfType :: Bool -> String -> m ()
kindOfType Bool
norm String
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (Type
ty, Type
kind) <- Bool -> String -> m (Type, Type)
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> String -> m (Type, Type)
GHC.typeKind Bool
norm String
str
    MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
str MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
pprTypeForUser Type
kind
                        , Bool -> MsgDoc -> MsgDoc
ppWhen Bool
norm (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc
equals MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
pprTypeForUser Type
ty ]

-----------------------------------------------------------------------------
-- :quit

quit :: Monad m => String -> m Bool
quit :: String -> m Bool
quit String
_ = Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True


-----------------------------------------------------------------------------
-- :script

-- running a script file #1363

scriptCmd :: String -> InputT GHCi ()
scriptCmd :: String -> InputT GHCi ()
scriptCmd String
ws = do
  case String -> [String]
words String
ws of
    [String
s]    -> String -> InputT GHCi ()
runScript String
s
    [String]
_      -> GhcException -> InputT GHCi ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax:  :script <filename>")

runScript :: String    -- ^ filename
           -> InputT GHCi ()
runScript :: String -> InputT GHCi ()
runScript String
filename = do
  String
filename' <- String -> InputT GHCi String
forall (m :: Type -> Type). MonadIO m => String -> m String
expandPath String
filename
  Either IOException Handle
either_script <- IO (Either IOException Handle)
-> InputT GHCi (Either IOException Handle)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Handle)
 -> InputT GHCi (Either IOException Handle))
-> IO (Either IOException Handle)
-> InputT GHCi (Either IOException Handle)
forall a b. (a -> b) -> a -> b
$ IO Handle -> IO (Either IOException Handle)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IOMode -> IO Handle
openFile String
filename' IOMode
ReadMode)
  case Either IOException Handle
either_script of
    Left IOException
_err    -> GhcException -> InputT GHCi ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ String
"IO error:  \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
filenameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++(IOException -> String
ioeGetErrorString IOException
_err))
    Right Handle
script -> do
      GHCiState
st <- InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      let prog :: String
prog = GHCiState -> String
progname GHCiState
st
          line :: Int
line = GHCiState -> Int
line_number GHCiState
st
      GHCiState -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{progname :: String
progname=String
filename',line_number :: Int
line_number=Int
0}
      Handle -> InputT GHCi ()
scriptLoop Handle
script
      IO () -> InputT GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ()) -> IO () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
script
      GHCiState
new_st <- InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      GHCiState -> InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
new_st{progname :: String
progname=String
prog,line_number :: Int
line_number=Int
line}
  where scriptLoop :: Handle -> InputT GHCi ()
scriptLoop Handle
script = do
          Maybe Bool
res <- (SomeException -> GHCi Bool)
-> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
forall (m :: Type -> Type). GhciMonad m => SomeException -> m Bool
handler (InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Handle -> InputT GHCi (Maybe String)
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe String)
fileLoop Handle
script
          case Maybe Bool
res of
            Maybe Bool
Nothing -> () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
            Just Bool
s  -> if Bool
s
              then Handle -> InputT GHCi ()
scriptLoop Handle
script
              else () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-----------------------------------------------------------------------------
-- :issafe

-- Displaying Safe Haskell properties of a module

isSafeCmd :: GHC.GhcMonad m => String -> m ()
isSafeCmd :: String -> m ()
isSafeCmd String
m =
    case String -> [String]
words String
m of
        [String
s] | String -> Bool
looksLikeModuleName String
s -> do
            Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
lookupModule String
s
            Module -> m ()
forall (m :: Type -> Type). GhcMonad m => Module -> m ()
isSafeModule Module
md
        [] -> do Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
guessCurrentModule String
"issafe"
                 Module -> m ()
forall (m :: Type -> Type). GhcMonad m => Module -> m ()
isSafeModule Module
md
        [String]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax:  :issafe <module>")

isSafeModule :: GHC.GhcMonad m => Module -> m ()
isSafeModule :: Module -> m ()
isSafeModule Module
m = do
    Maybe ModuleInfo
mb_mod_info <- Module -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
m
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe ModuleInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ModuleInfo
mb_mod_info)
         (GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ String
"unknown module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mname)

    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    let iface :: Maybe ModIface
iface = ModuleInfo -> Maybe ModIface
GHC.modInfoIface (ModuleInfo -> Maybe ModIface) -> ModuleInfo -> Maybe ModIface
forall a b. (a -> b) -> a -> b
$ Maybe ModuleInfo -> ModuleInfo
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ModuleInfo
mb_mod_info
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe ModIface -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ModIface
iface)
         (GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ String
"can't load interface file for module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    (ModuleName -> String
GHC.moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
GHC.moduleName Module
m))

    (Bool
msafe, Set InstalledUnitId
pkgs) <- Module -> m (Bool, Set InstalledUnitId)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Bool, Set InstalledUnitId)
GHC.moduleTrustReqs Module
m
    let trust :: String
trust  = DynFlags -> SafeHaskellMode -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (SafeHaskellMode -> String) -> SafeHaskellMode -> String
forall a b. (a -> b) -> a -> b
$ IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
GHC.mi_trust (ModIface -> IfaceTrustInfo) -> ModIface -> IfaceTrustInfo
forall a b. (a -> b) -> a -> b
$ Maybe ModIface -> ModIface
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ModIface
iface
        pkg :: String
pkg    = if DynFlags -> Module -> Bool
packageTrusted DynFlags
dflags Module
m then String
"trusted" else String
"untrusted"
        (Set InstalledUnitId
good, Set InstalledUnitId
bad) = DynFlags
-> Set InstalledUnitId
-> (Set InstalledUnitId, Set InstalledUnitId)
tallyPkgs DynFlags
dflags Set InstalledUnitId
pkgs

    -- print info to user...
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Trust type is (Module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
trust String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", Package: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Package Trust: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if DynFlags -> Bool
packageTrustOn DynFlags
dflags then String
"On" else String
"Off")
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set InstalledUnitId -> Bool
forall a. Set a -> Bool
S.null Set InstalledUnitId
good)
         (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Trusted package dependencies (trusted): " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (InstalledUnitId -> String) -> [InstalledUnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> InstalledUnitId -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) (Set InstalledUnitId -> [InstalledUnitId]
forall a. Set a -> [a]
S.toList Set InstalledUnitId
good)))
    case Bool
msafe Bool -> Bool -> Bool
&& Set InstalledUnitId -> Bool
forall a. Set a -> Bool
S.null Set InstalledUnitId
bad of
        Bool
True -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
mname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is trusted!"
        Bool
False -> do
            Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set InstalledUnitId -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null Set InstalledUnitId
bad)
                 (IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Trusted package dependencies (untrusted): "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (InstalledUnitId -> String) -> [InstalledUnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> InstalledUnitId -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) (Set InstalledUnitId -> [InstalledUnitId]
forall a. Set a -> [a]
S.toList Set InstalledUnitId
bad)))
            IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
mname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is NOT trusted!"

  where
    mname :: String
mname = ModuleName -> String
GHC.moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
GHC.moduleName Module
m

    packageTrusted :: DynFlags -> Module -> Bool
packageTrusted DynFlags
dflags Module
md
        | DynFlags -> UnitId
thisPackage DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> UnitId
moduleUnitId Module
md = Bool
True
        | Bool
otherwise = InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> Bool)
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> UnitId
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
getPackageDetails DynFlags
dflags (Module -> UnitId
moduleUnitId Module
md)

    tallyPkgs :: DynFlags
-> Set InstalledUnitId
-> (Set InstalledUnitId, Set InstalledUnitId)
tallyPkgs DynFlags
dflags Set InstalledUnitId
deps | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) = (Set InstalledUnitId
forall a. Set a
S.empty, Set InstalledUnitId
forall a. Set a
S.empty)
                          | Bool
otherwise = (InstalledUnitId -> Bool)
-> Set InstalledUnitId
-> (Set InstalledUnitId, Set InstalledUnitId)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
S.partition InstalledUnitId -> Bool
part Set InstalledUnitId
deps
        where part :: InstalledUnitId -> Bool
part InstalledUnitId
pkg = InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> Bool)
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> InstalledUnitId
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
getInstalledPackageDetails DynFlags
dflags InstalledUnitId
pkg

-----------------------------------------------------------------------------
-- :browse

-- Browsing a module's contents

browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()
browseCmd :: Bool -> String -> m ()
browseCmd Bool
bang String
m =
  case String -> [String]
words String
m of
    [Char
'*':String
s] | String -> Bool
looksLikeModuleName String
s -> do
        Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
wantInterpretedModule String
s
        Bool -> Module -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Module -> Bool -> m ()
browseModule Bool
bang Module
md Bool
False
    [String
s] | String -> Bool
looksLikeModuleName String
s -> do
        Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
lookupModule String
s
        Bool -> Module -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Module -> Bool -> m ()
browseModule Bool
bang Module
md Bool
True
    [] -> do Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
guessCurrentModule (String
"browse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
bang then String
"!" else String
"")
             Bool -> Module -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Module -> Bool -> m ()
browseModule Bool
bang Module
md Bool
True
    [String]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax:  :browse <module>")

guessCurrentModule :: GHC.GhcMonad m => String -> m Module
-- Guess which module the user wants to browse.  Pick
-- modules that are interpreted first.  The most
-- recently-added module occurs last, it seems.
guessCurrentModule :: String -> m Module
guessCurrentModule String
cmd
  = do [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
       Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ([InteractiveImport] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [InteractiveImport]
imports) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$
          String -> GhcException
CmdLineError (Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": no current module")
       case ([InteractiveImport] -> InteractiveImport
forall a. [a] -> a
head [InteractiveImport]
imports) of
          IIModule ModuleName
m -> ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
m Maybe FastString
forall a. Maybe a
Nothing
          IIDecl ImportDecl GhcPs
d   -> ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d))
                                       ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (Maybe StringLiteral -> Maybe FastString)
-> Maybe StringLiteral -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
d)

-- without bang, show items in context of their parents and omit children
-- with bang, show class methods and data constructors separately, and
--            indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()
browseModule :: Bool -> Module -> Bool -> m ()
browseModule Bool
bang Module
modl Bool
exports_only = do
  -- :browse reports qualifiers wrt current context
  PrintUnqualified
unqual <- m PrintUnqualified
forall (m :: Type -> Type). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual

  Maybe ModuleInfo
mb_mod_info <- Module -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
modl
  case Maybe ModuleInfo
mb_mod_info of
    Maybe ModuleInfo
Nothing -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"unknown module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
GHC.moduleName Module
modl)))
    Just ModuleInfo
mod_info -> do
        DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
        let names :: [Name]
names
               | Bool
exports_only = ModuleInfo -> [Name]
GHC.modInfoExports ModuleInfo
mod_info
               | Bool
otherwise    = ModuleInfo -> Maybe [Name]
GHC.modInfoTopLevelScope ModuleInfo
mod_info
                                Maybe [Name] -> [Name] -> [Name]
forall a. Maybe a -> a -> a
`orElse` []

                -- sort alphabetically name, but putting locally-defined
                -- identifiers first. We would like to improve this; see #1799.
            sorted_names :: [Name]
sorted_names = [Name] -> [Name]
loc_sort [Name]
local [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name] -> [Name]
occ_sort [Name]
external
                where
                ([Name]
local,[Name]
external) = ASSERT( all isExternalName names )
                                   (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
==Module
modl) (Module -> Bool) -> (Name -> Module) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule) [Name]
names
                occ_sort :: [Name] -> [Name]
occ_sort = (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (OccName -> OccName -> Ordering)
-> (Name -> OccName) -> Name -> Name -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Name -> OccName
nameOccName)
                -- try to sort by src location. If the first name in our list
                -- has a good source location, then they all should.
                loc_sort :: [Name] -> [Name]
loc_sort [Name]
ns
                      | Name
n:[Name]
_ <- [Name]
ns, SrcSpan -> Bool
isGoodSrcSpan (Name -> SrcSpan
nameSrcSpan Name
n)
                      = (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> SrcSpan -> Ordering)
-> (Name -> SrcSpan) -> Name -> Name -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Name -> SrcSpan
nameSrcSpan) [Name]
ns
                      | Bool
otherwise
                      = [Name] -> [Name]
occ_sort [Name]
ns

        [Maybe TyThing]
mb_things <- (Name -> m (Maybe TyThing)) -> [Name] -> m [Maybe TyThing]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName [Name]
sorted_names
        let filtered_things :: [TyThing]
filtered_things = (TyThing -> TyThing) -> [TyThing] -> [TyThing]
forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren (\TyThing
t -> TyThing
t) ([Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TyThing]
mb_things)

        GlobalRdrEnv
rdr_env <- m GlobalRdrEnv
forall (m :: Type -> Type). GhcMonad m => m GlobalRdrEnv
GHC.getGRE

        let things :: [TyThing]
things | Bool
bang      = [Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TyThing]
mb_things
                   | Bool
otherwise = [TyThing]
filtered_things
            pretty :: TyThing -> MsgDoc
pretty | Bool
bang      = ShowSub -> TyThing -> MsgDoc
pprTyThing ShowSub
showToHeader
                   | Bool
otherwise = ShowSub -> TyThing -> MsgDoc
pprTyThingInContext ShowSub
showToHeader

            labels :: [Maybe [ModuleName]] -> MsgDoc
labels  [] = String -> MsgDoc
text String
"-- not currently imported"
            labels  [Maybe [ModuleName]]
l  = String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Maybe [ModuleName] -> String) -> [Maybe [ModuleName]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Maybe [ModuleName] -> String
qualifier [Maybe [ModuleName]]
l

            qualifier :: Maybe [ModuleName] -> String
            qualifier :: Maybe [ModuleName] -> String
qualifier  = String -> ([ModuleName] -> String) -> Maybe [ModuleName] -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"-- defined locally"
                             ((String
"-- imported via "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ([ModuleName] -> String) -> [ModuleName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                               ([String] -> String)
-> ([ModuleName] -> [String]) -> [ModuleName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
GHC.moduleNameString)
            importInfo :: Name -> [Maybe [ModuleName]]
importInfo = GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
RdrName.getGRE_NameQualifier_maybes GlobalRdrEnv
rdr_env

            modNames :: [[Maybe [ModuleName]]]
            modNames :: [[Maybe [ModuleName]]]
modNames   = (TyThing -> [Maybe [ModuleName]])
-> [TyThing] -> [[Maybe [ModuleName]]]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Maybe [ModuleName]]
importInfo (Name -> [Maybe [ModuleName]])
-> (TyThing -> Name) -> TyThing -> [Maybe [ModuleName]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName) [TyThing]
things

            -- annotate groups of imports with their import modules
            -- the default ordering is somewhat arbitrary, so we group
            -- by header and sort groups; the names themselves should
            -- really come in order of source appearance.. (trac #1799)
            annotate :: [([Maybe [ModuleName]], MsgDoc)] -> [MsgDoc]
annotate [([Maybe [ModuleName]], MsgDoc)]
mts = (([Maybe [ModuleName]], [MsgDoc]) -> [MsgDoc])
-> [([Maybe [ModuleName]], [MsgDoc])] -> [MsgDoc]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (\([Maybe [ModuleName]]
m,[MsgDoc]
ts)->[Maybe [ModuleName]] -> MsgDoc
labels [Maybe [ModuleName]]
mMsgDoc -> [MsgDoc] -> [MsgDoc]
forall a. a -> [a] -> [a]
:[MsgDoc]
ts)
                         ([([Maybe [ModuleName]], [MsgDoc])] -> [MsgDoc])
-> [([Maybe [ModuleName]], [MsgDoc])] -> [MsgDoc]
forall a b. (a -> b) -> a -> b
$ (([Maybe [ModuleName]], [MsgDoc])
 -> ([Maybe [ModuleName]], [MsgDoc]) -> Ordering)
-> [([Maybe [ModuleName]], [MsgDoc])]
-> [([Maybe [ModuleName]], [MsgDoc])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ([Maybe [ModuleName]], [MsgDoc])
-> ([Maybe [ModuleName]], [MsgDoc]) -> Ordering
forall b.
([Maybe [ModuleName]], b) -> ([Maybe [ModuleName]], b) -> Ordering
cmpQualifiers ([([Maybe [ModuleName]], [MsgDoc])]
 -> [([Maybe [ModuleName]], [MsgDoc])])
-> [([Maybe [ModuleName]], [MsgDoc])]
-> [([Maybe [ModuleName]], [MsgDoc])]
forall a b. (a -> b) -> a -> b
$ [([Maybe [ModuleName]], MsgDoc)]
-> [([Maybe [ModuleName]], [MsgDoc])]
forall a b. Eq a => [(a, b)] -> [(a, [b])]
grp [([Maybe [ModuleName]], MsgDoc)]
mts
              where cmpQualifiers :: ([Maybe [ModuleName]], b) -> ([Maybe [ModuleName]], b) -> Ordering
cmpQualifiers =
                      [Maybe [FastString]] -> [Maybe [FastString]] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Maybe [FastString]] -> [Maybe [FastString]] -> Ordering)
-> (([Maybe [ModuleName]], b) -> [Maybe [FastString]])
-> ([Maybe [ModuleName]], b)
-> ([Maybe [ModuleName]], b)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Maybe [ModuleName] -> Maybe [FastString])
-> [Maybe [ModuleName]] -> [Maybe [FastString]]
forall a b. (a -> b) -> [a] -> [b]
map (([ModuleName] -> [FastString])
-> Maybe [ModuleName] -> Maybe [FastString]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ModuleName -> FastString) -> [ModuleName] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> FastString
moduleNameFS)) ([Maybe [ModuleName]] -> [Maybe [FastString]])
-> (([Maybe [ModuleName]], b) -> [Maybe [ModuleName]])
-> ([Maybe [ModuleName]], b)
-> [Maybe [FastString]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe [ModuleName]], b) -> [Maybe [ModuleName]]
forall a b. (a, b) -> a
fst)
            grp :: [(a, b)] -> [(a, [b])]
grp []            = []
            grp mts :: [(a, b)]
mts@((a
m,b
_):[(a, b)]
_) = (a
m,((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
g) (a, [b]) -> [(a, [b])] -> [(a, [b])]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, [b])]
grp [(a, b)]
ng
              where ([(a, b)]
g,[(a, b)]
ng) = ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
m)(a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
mts

        let prettyThings, prettyThings' :: [SDoc]
            prettyThings :: [MsgDoc]
prettyThings = (TyThing -> MsgDoc) -> [TyThing] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> MsgDoc
pretty [TyThing]
things
            prettyThings' :: [MsgDoc]
prettyThings' | Bool
bang      = [([Maybe [ModuleName]], MsgDoc)] -> [MsgDoc]
annotate ([([Maybe [ModuleName]], MsgDoc)] -> [MsgDoc])
-> [([Maybe [ModuleName]], MsgDoc)] -> [MsgDoc]
forall a b. (a -> b) -> a -> b
$ [[Maybe [ModuleName]]]
-> [MsgDoc] -> [([Maybe [ModuleName]], MsgDoc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Maybe [ModuleName]]]
modNames [MsgDoc]
prettyThings
                          | Bool
otherwise = [MsgDoc]
prettyThings
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> PrintUnqualified -> MsgDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
unqual ([MsgDoc] -> MsgDoc
vcat [MsgDoc]
prettyThings')
        -- ToDo: modInfoInstances currently throws an exception for
        -- package modules.  When it works, we can do this:
        --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))


-----------------------------------------------------------------------------
-- :module

-- Setting the module context.  For details on context handling see
-- "remembered_ctx" and "transient_ctx" in GhciMonad.

moduleCmd :: GhciMonad m => String -> m ()
moduleCmd :: String -> m ()
moduleCmd String
str
  | (String -> Bool) -> [String] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all String -> Bool
sensible [String]
strs = m ()
cmd
  | Bool
otherwise = GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"syntax:  :module [+/-] [*]M1 ... [*]Mn")
  where
    (m ()
cmd, [String]
strs) =
        case String
str of
          Char
'+':String
stuff -> ([ModuleName] -> [ModuleName] -> m ())
-> String -> (m (), [String])
forall a.
([ModuleName] -> [ModuleName] -> a) -> String -> (a, [String])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
addModulesToContext   String
stuff
          Char
'-':String
stuff -> ([ModuleName] -> [ModuleName] -> m ())
-> String -> (m (), [String])
forall a.
([ModuleName] -> [ModuleName] -> a) -> String -> (a, [String])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
remModulesFromContext String
stuff
          String
stuff     -> ([ModuleName] -> [ModuleName] -> m ())
-> String -> (m (), [String])
forall a.
([ModuleName] -> [ModuleName] -> a) -> String -> (a, [String])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
setContext            String
stuff

    rest :: ([ModuleName] -> [ModuleName] -> a) -> String -> (a, [String])
rest [ModuleName] -> [ModuleName] -> a
op String
stuff = ([ModuleName] -> [ModuleName] -> a
op [ModuleName]
as [ModuleName]
bs, [String]
stuffs)
       where ([ModuleName]
as,[ModuleName]
bs) = (String -> Either ModuleName ModuleName)
-> [String] -> ([ModuleName], [ModuleName])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith String -> Either ModuleName ModuleName
starred [String]
stuffs
             stuffs :: [String]
stuffs  = String -> [String]
words String
stuff

    sensible :: String -> Bool
sensible (Char
'*':String
m) = String -> Bool
looksLikeModuleName String
m
    sensible String
m       = String -> Bool
looksLikeModuleName String
m

    starred :: String -> Either ModuleName ModuleName
starred (Char
'*':String
m) = ModuleName -> Either ModuleName ModuleName
forall a b. a -> Either a b
Left  (String -> ModuleName
GHC.mkModuleName String
m)
    starred String
m       = ModuleName -> Either ModuleName ModuleName
forall a b. b -> Either a b
Right (String -> ModuleName
GHC.mkModuleName String
m)


-- -----------------------------------------------------------------------------
-- Four ways to manipulate the context:
--   (a) :module +<stuff>:     addModulesToContext
--   (b) :module -<stuff>:     remModulesFromContext
--   (c) :module <stuff>:      setContext
--   (d) import <module>...:   addImportToContext

addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext :: [ModuleName] -> [ModuleName] -> m ()
addModulesToContext [ModuleName]
starred [ModuleName]
unstarred = m () -> m ()
forall (m :: Type -> Type) a. GhciMonad m => m a -> m a
restoreContextOnFailure (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
   [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ [ModuleName]
starred [ModuleName]
unstarred

addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ :: [ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ [ModuleName]
starred [ModuleName]
unstarred = do
   (InteractiveImport -> m ()) -> [InteractiveImport] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InteractiveImport -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
InteractiveImport -> m ()
addII ((ModuleName -> InteractiveImport)
-> [ModuleName] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> InteractiveImport
mkIIModule [ModuleName]
starred [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ (ModuleName -> InteractiveImport)
-> [ModuleName] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> InteractiveImport
mkIIDecl [ModuleName]
unstarred)
   m ()
forall (m :: Type -> Type). GhciMonad m => m ()
setGHCContextFromGHCiState

remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
remModulesFromContext :: [ModuleName] -> [ModuleName] -> m ()
remModulesFromContext  [ModuleName]
starred [ModuleName]
unstarred = do
   -- we do *not* call restoreContextOnFailure here.  If the user
   -- is trying to fix up a context that contains errors by removing
   -- modules, we don't want GHC to silently put them back in again.
   (ModuleName -> m ()) -> [ModuleName] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ModuleName -> m ()
forall (m :: Type -> Type). GhciMonad m => ModuleName -> m ()
rm ([ModuleName]
starred [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
unstarred)
   m ()
forall (m :: Type -> Type). GhciMonad m => m ()
setGHCContextFromGHCiState
 where
   rm :: GhciMonad m => ModuleName -> m ()
   rm :: ModuleName -> m ()
rm ModuleName
str = do
     ModuleName
m <- Module -> ModuleName
moduleName (Module -> ModuleName) -> m Module -> m ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
lookupModuleName ModuleName
str
     let filt :: [InteractiveImport] -> [InteractiveImport]
filt = (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
(/=) ModuleName
m (ModuleName -> Bool)
-> (InteractiveImport -> ModuleName) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveImport -> ModuleName
iiModuleName)
     (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st ->
        GHCiState
st { remembered_ctx :: [InteractiveImport]
remembered_ctx = [InteractiveImport] -> [InteractiveImport]
filt (GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st)
           , transient_ctx :: [InteractiveImport]
transient_ctx  = [InteractiveImport] -> [InteractiveImport]
filt (GHCiState -> [InteractiveImport]
transient_ctx GHCiState
st) }

setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
setContext :: [ModuleName] -> [ModuleName] -> m ()
setContext [ModuleName]
starred [ModuleName]
unstarred = m () -> m ()
forall (m :: Type -> Type) a. GhciMonad m => m a -> m a
restoreContextOnFailure (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st -> GHCiState
st { remembered_ctx :: [InteractiveImport]
remembered_ctx = [], transient_ctx :: [InteractiveImport]
transient_ctx = [] }
                                -- delete the transient context
  [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ [ModuleName]
starred [ModuleName]
unstarred

addImportToContext :: GhciMonad m => String -> m ()
addImportToContext :: String -> m ()
addImportToContext String
str = m () -> m ()
forall (m :: Type -> Type) a. GhciMonad m => m a -> m a
restoreContextOnFailure (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ImportDecl GhcPs
idecl <- String -> m (ImportDecl GhcPs)
forall (m :: Type -> Type).
GhcMonad m =>
String -> m (ImportDecl GhcPs)
GHC.parseImportDecl String
str
  InteractiveImport -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
InteractiveImport -> m ()
addII (ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
idecl)   -- #5836
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
setGHCContextFromGHCiState

-- Util used by addImportToContext and addModulesToContext
addII :: GhciMonad m => InteractiveImport -> m ()
addII :: InteractiveImport -> m ()
addII InteractiveImport
iidecl = do
  InteractiveImport -> m ()
forall (m :: Type -> Type). GhcMonad m => InteractiveImport -> m ()
checkAdd InteractiveImport
iidecl
  (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st ->
     GHCiState
st { remembered_ctx :: [InteractiveImport]
remembered_ctx = InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
addNotSubsumed InteractiveImport
iidecl (GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st)
        , transient_ctx :: [InteractiveImport]
transient_ctx = (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InteractiveImport -> Bool) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InteractiveImport
iidecl InteractiveImport -> InteractiveImport -> Bool
`iiSubsumes`))
                                 (GHCiState -> [InteractiveImport]
transient_ctx GHCiState
st)
        }

-- Sometimes we can't tell whether an import is valid or not until
-- we finally call 'GHC.setContext'.  e.g.
--
--   import System.IO (foo)
--
-- will fail because System.IO does not export foo.  In this case we
-- don't want to store the import in the context permanently, so we
-- catch the failure from 'setGHCContextFromGHCiState' and set the
-- context back to what it was.
--
-- See #6007
--
restoreContextOnFailure :: GhciMonad m => m a -> m a
restoreContextOnFailure :: m a -> m a
restoreContextOnFailure m a
do_this = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let rc :: [InteractiveImport]
rc = GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st; tc :: [InteractiveImport]
tc = GHCiState -> [InteractiveImport]
transient_ctx GHCiState
st
  m a
do_this m a -> m () -> m a
forall (m :: Type -> Type) a b.
ExceptionMonad m =>
m a -> m b -> m a
`gonException` ((GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState ((GHCiState -> GHCiState) -> m ())
-> (GHCiState -> GHCiState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHCiState
st' ->
     GHCiState
st' { remembered_ctx :: [InteractiveImport]
remembered_ctx = [InteractiveImport]
rc, transient_ctx :: [InteractiveImport]
transient_ctx = [InteractiveImport]
tc })

-- -----------------------------------------------------------------------------
-- Validate a module that we want to add to the context

checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()
checkAdd :: InteractiveImport -> m ()
checkAdd InteractiveImport
ii = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  let safe :: Bool
safe = DynFlags -> Bool
safeLanguageOn DynFlags
dflags
  case InteractiveImport
ii of
    IIModule ModuleName
modname
       | Bool
safe -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError String
"can't use * imports with Safe Haskell"
       | Bool
otherwise -> ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName ModuleName
modname m Module -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

    IIDecl ImportDecl GhcPs
d -> do
       let modname :: SrcSpanLess (Located ModuleName)
modname = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d)
           pkgqual :: Maybe StringLiteral
pkgqual = ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl GhcPs
d
       Module
m <- ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.lookupModule ModuleName
modname ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs Maybe StringLiteral
pkgqual)
       Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
safe (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
           Bool
t <- Module -> m Bool
forall (m :: Type -> Type). GhcMonad m => Module -> m Bool
GHC.isModuleTrusted Module
m
           Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
t) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
ProgramError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ String
""

-- -----------------------------------------------------------------------------
-- Update the GHC API's view of the context

-- | Sets the GHC context from the GHCi state.  The GHC context is
-- always set this way, we never modify it incrementally.
--
-- We ignore any imports for which the ModuleName does not currently
-- exist.  This is so that the remembered_ctx can contain imports for
-- modules that are not currently loaded, perhaps because we just did
-- a :reload and encountered errors.
--
-- Prelude is added if not already present in the list.  Therefore to
-- override the implicit Prelude import you can say 'import Prelude ()'
-- at the prompt, just as in Haskell source.
--
setGHCContextFromGHCiState :: GhciMonad m => m ()
setGHCContextFromGHCiState :: m ()
setGHCContextFromGHCiState = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      -- re-use checkAdd to check whether the module is valid.  If the
      -- module does not exist, we do *not* want to print an error
      -- here, we just want to silently keep the module in the context
      -- until such time as the module reappears again.  So we ignore
      -- the actual exception thrown by checkAdd, using tryBool to
      -- turn it into a Bool.
  [InteractiveImport]
iidecls <- (InteractiveImport -> m Bool)
-> [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (m () -> m Bool
forall (m :: Type -> Type) a. ExceptionMonad m => m a -> m Bool
tryBool(m () -> m Bool)
-> (InteractiveImport -> m ()) -> InteractiveImport -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.InteractiveImport -> m ()
forall (m :: Type -> Type). GhcMonad m => InteractiveImport -> m ()
checkAdd) (GHCiState -> [InteractiveImport]
transient_ctx GHCiState
st [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st)

  [InteractiveImport]
prel_iidecls <- [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type).
GhciMonad m =>
[InteractiveImport] -> m [InteractiveImport]
getImplicitPreludeImports [InteractiveImport]
iidecls
  [InteractiveImport]
valid_prel_iidecls <- (InteractiveImport -> m Bool)
-> [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (m () -> m Bool
forall (m :: Type -> Type) a. ExceptionMonad m => m a -> m Bool
tryBool (m () -> m Bool)
-> (InteractiveImport -> m ()) -> InteractiveImport -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveImport -> m ()
forall (m :: Type -> Type). GhcMonad m => InteractiveImport -> m ()
checkAdd) [InteractiveImport]
prel_iidecls

  [InteractiveImport]
extra_imports <- (InteractiveImport -> m Bool)
-> [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (m () -> m Bool
forall (m :: Type -> Type) a. ExceptionMonad m => m a -> m Bool
tryBool (m () -> m Bool)
-> (InteractiveImport -> m ()) -> InteractiveImport -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveImport -> m ()
forall (m :: Type -> Type). GhcMonad m => InteractiveImport -> m ()
checkAdd) ((ImportDecl GhcPs -> InteractiveImport)
-> [ImportDecl GhcPs] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
IIDecl (GHCiState -> [ImportDecl GhcPs]
extra_imports GHCiState
st))

  [InteractiveImport] -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
[InteractiveImport] -> m ()
GHC.setContext ([InteractiveImport] -> m ()) -> [InteractiveImport] -> m ()
forall a b. (a -> b) -> a -> b
$ [InteractiveImport]
iidecls [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
extra_imports [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
valid_prel_iidecls


getImplicitPreludeImports :: GhciMonad m
                          => [InteractiveImport] -> m [InteractiveImport]
getImplicitPreludeImports :: [InteractiveImport] -> m [InteractiveImport]
getImplicitPreludeImports [InteractiveImport]
iidecls = do
     -- allow :seti to override -XNoImplicitPrelude
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState

  -- We add the prelude imports if there are no *-imports, and we also
  -- allow each prelude import to be subsumed by another explicit import
  -- of the same module.  This means that you can override the prelude import
  -- with "import Prelude hiding (map)", for example.
  let prel_iidecls :: [InteractiveImport]
prel_iidecls =
        if Bool -> Bool
not ((InteractiveImport -> Bool) -> [InteractiveImport] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any InteractiveImport -> Bool
isIIModule [InteractiveImport]
iidecls)
            then [ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
imp
                 | ImportDecl GhcPs
imp <- GHCiState -> [ImportDecl GhcPs]
prelude_imports GHCiState
st
                 , Bool -> Bool
not ((InteractiveImport -> Bool) -> [InteractiveImport] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (ImportDecl GhcPs -> InteractiveImport -> Bool
sameImpModule ImportDecl GhcPs
imp) [InteractiveImport]
iidecls) ]
            else []

  [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [InteractiveImport]
prel_iidecls

-- -----------------------------------------------------------------------------
-- Utils on InteractiveImport

mkIIModule :: ModuleName -> InteractiveImport
mkIIModule :: ModuleName -> InteractiveImport
mkIIModule = ModuleName -> InteractiveImport
IIModule

mkIIDecl :: ModuleName -> InteractiveImport
mkIIDecl :: ModuleName -> InteractiveImport
mkIIDecl = ImportDecl GhcPs -> InteractiveImport
IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> (ModuleName -> ImportDecl GhcPs)
-> ModuleName
-> InteractiveImport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> ImportDecl GhcPs
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl

iiModules :: [InteractiveImport] -> [ModuleName]
iiModules :: [InteractiveImport] -> [ModuleName]
iiModules [InteractiveImport]
is = [ModuleName
m | IIModule ModuleName
m <- [InteractiveImport]
is]

isIIModule :: InteractiveImport -> Bool
isIIModule :: InteractiveImport -> Bool
isIIModule (IIModule ModuleName
_) = Bool
True
isIIModule InteractiveImport
_ = Bool
False

iiModuleName :: InteractiveImport -> ModuleName
iiModuleName :: InteractiveImport -> ModuleName
iiModuleName (IIModule ModuleName
m) = ModuleName
m
iiModuleName (IIDecl ImportDecl GhcPs
d)   = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d)

preludeModuleName :: ModuleName
preludeModuleName :: ModuleName
preludeModuleName = String -> ModuleName
GHC.mkModuleName String
"Clash.Prelude"

sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
sameImpModule ImportDecl GhcPs
_ (IIModule ModuleName
_) = Bool
False -- we only care about imports here
sameImpModule ImportDecl GhcPs
imp (IIDecl ImportDecl GhcPs
d) = Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
imp)

addNotSubsumed :: InteractiveImport
               -> [InteractiveImport] -> [InteractiveImport]
addNotSubsumed :: InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
addNotSubsumed InteractiveImport
i [InteractiveImport]
is
  | (InteractiveImport -> Bool) -> [InteractiveImport] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (InteractiveImport -> InteractiveImport -> Bool
`iiSubsumes` InteractiveImport
i) [InteractiveImport]
is = [InteractiveImport]
is
  | Bool
otherwise               = InteractiveImport
i InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (InteractiveImport -> Bool) -> InteractiveImport -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InteractiveImport
i InteractiveImport -> InteractiveImport -> Bool
`iiSubsumes`)) [InteractiveImport]
is

-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
-- by any of @is@.
filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
               -> [InteractiveImport]
filterSubsumed :: [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
filterSubsumed [InteractiveImport]
is [InteractiveImport]
js = (InteractiveImport -> Bool)
-> [InteractiveImport] -> [InteractiveImport]
forall a. (a -> Bool) -> [a] -> [a]
filter (\InteractiveImport
j -> Bool -> Bool
not ((InteractiveImport -> Bool) -> [InteractiveImport] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (InteractiveImport -> InteractiveImport -> Bool
`iiSubsumes` InteractiveImport
j) [InteractiveImport]
is)) [InteractiveImport]
js

-- | Returns True if the left import subsumes the right one.  Doesn't
-- need to be 100% accurate, conservatively returning False is fine.
-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
-- plusProv will ensue (#5904))
--
-- Note that an IIModule does not necessarily subsume an IIDecl,
-- because e.g. a module might export a name that is only available
-- qualified within the module itself.
--
-- Note that 'import M' does not necessarily subsume 'import M(foo)',
-- because M might not export foo and we want an error to be produced
-- in that case.
--
iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
iiSubsumes (IIModule ModuleName
m1) (IIModule ModuleName
m2) = ModuleName
m1ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==ModuleName
m2
iiSubsumes (IIDecl ImportDecl GhcPs
d1) (IIDecl ImportDecl GhcPs
d2)      -- A bit crude
  =  Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d1) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName ImportDecl GhcPs
d2)
     Bool -> Bool -> Bool
&& ImportDecl GhcPs -> Maybe (Located ModuleName)
forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclAs ImportDecl GhcPs
d1 Maybe (Located ModuleName) -> Maybe (Located ModuleName) -> Bool
forall a. Eq a => a -> a -> Bool
== ImportDecl GhcPs -> Maybe (Located ModuleName)
forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclAs ImportDecl GhcPs
d2
     Bool -> Bool -> Bool
&& (Bool -> Bool
not (ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
d1)) Bool -> Bool -> Bool
|| ImportDeclQualifiedStyle -> Bool
isImportDeclQualified (ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified ImportDecl GhcPs
d2))
     Bool -> Bool -> Bool
&& (ImportDecl GhcPs -> Maybe (Bool, Located [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl GhcPs
d1 Maybe (Bool, Located [LIE GhcPs])
-> Maybe (Bool, Located [LIE GhcPs]) -> Bool
forall a l.
(Eq a, Eq l) =>
Maybe (Bool, GenLocated l [a])
-> Maybe (Bool, GenLocated l [a]) -> Bool
`hidingSubsumes` ImportDecl GhcPs -> Maybe (Bool, Located [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl GhcPs
d2)
  where
     Maybe (Bool, GenLocated l [a])
_                    hidingSubsumes :: Maybe (Bool, GenLocated l [a])
-> Maybe (Bool, GenLocated l [a]) -> Bool
`hidingSubsumes` Just (Bool
False,L l
_ []) = Bool
True
     Just (Bool
False, L l
_ [a]
xs) `hidingSubsumes` Just (Bool
False,L l
_ [a]
ys)
                                                           = (a -> Bool) -> [a] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [a]
xs) [a]
ys
     Maybe (Bool, GenLocated l [a])
h1                   `hidingSubsumes` Maybe (Bool, GenLocated l [a])
h2              = Maybe (Bool, GenLocated l [a])
h1 Maybe (Bool, GenLocated l [a])
-> Maybe (Bool, GenLocated l [a]) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (Bool, GenLocated l [a])
h2
iiSubsumes InteractiveImport
_ InteractiveImport
_ = Bool
False


----------------------------------------------------------------------------
-- :set

-- set options in the interpreter.  Syntax is exactly the same as the
-- ghc command line, except that certain options aren't available (-C,
-- -E etc.)
--
-- This is pretty fragile: most options won't work as expected.  ToDo:
-- figure out which ones & disallow them.

setCmd :: GhciMonad m => String -> m ()
setCmd :: String -> m ()
setCmd String
""   = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
False
setCmd String
"-a" = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
True
setCmd String
str
  = case String -> Either String (String, String)
getCmd String
str of
    Right (String
"args",    String
rest) ->
        case String -> Either String [String]
toArgs String
rest of
            Left String
err -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err)
            Right [String]
args -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
setArgs [String]
args
    Right (String
"prog",    String
rest) ->
        case String -> Either String [String]
toArgs String
rest of
            Right [String
prog] -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setProg String
prog
            Either String [String]
_ -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"syntax: :set prog <progname>")

    Right (String
"prompt",           String
rest) ->
        (PromptFunction -> m ()) -> String -> String -> m ()
forall (m :: Type -> Type).
MonadIO m =>
(PromptFunction -> m ()) -> String -> String -> m ()
setPromptString PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPrompt ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest)
                        String
"syntax: set prompt <string>"
    Right (String
"prompt-function",  String
rest) ->
        (PromptFunction -> m ()) -> String -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(PromptFunction -> m ()) -> String -> m ()
setPromptFunc PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPrompt (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
    Right (String
"prompt-cont",          String
rest) ->
        (PromptFunction -> m ()) -> String -> String -> m ()
forall (m :: Type -> Type).
MonadIO m =>
(PromptFunction -> m ()) -> String -> String -> m ()
setPromptString PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPromptCont ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest)
                        String
"syntax: :set prompt-cont <string>"
    Right (String
"prompt-cont-function", String
rest) ->
        (PromptFunction -> m ()) -> String -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(PromptFunction -> m ()) -> String -> m ()
setPromptFunc PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPromptCont (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest

    Right (String
"editor",  String
rest) -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setEditor  (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
    Right (String
"stop",    String
rest) -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setStop    (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
    Right (String
"local-config", String
rest) ->
        String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setLocalConfigBehaviour (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
    Either String (String, String)
_ -> case String -> Either String [String]
toArgs String
str of
         Left String
err -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err)
         Right [String]
wds -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
setOptions [String]
wds

setiCmd :: GhciMonad m => String -> m ()
setiCmd :: String -> m ()
setiCmd String
""   = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DynFlags -> IO ()
showDynFlags Bool
False
setiCmd String
"-a" = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DynFlags -> IO ()
showDynFlags Bool
True
setiCmd String
str  =
  case String -> Either String [String]
toArgs String
str of
    Left String
err -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err)
    Right [String]
wds -> Bool -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [String] -> m ()
newDynFlags Bool
True [String]
wds

showOptions :: GhciMonad m => Bool -> m ()
showOptions :: Bool -> m ()
showOptions Bool
show_all
  = do GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
       DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
       let opts :: [GHCiOption]
opts = GHCiState -> [GHCiOption]
options GHCiState
st
       IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (
              String -> MsgDoc
text String
"options currently set: " MsgDoc -> MsgDoc -> MsgDoc
<>
              if [GHCiOption] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [GHCiOption]
opts
                   then String -> MsgDoc
text String
"none."
                   else [MsgDoc] -> MsgDoc
hsep ((GHCiOption -> MsgDoc) -> [GHCiOption] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\GHCiOption
o -> Char -> MsgDoc
char Char
'+' MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text (GHCiOption -> String
optToStr GHCiOption
o)) [GHCiOption]
opts)
           ))
       m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DynFlags -> IO ()
showDynFlags Bool
show_all


showDynFlags :: Bool -> DynFlags -> IO ()
showDynFlags :: Bool -> DynFlags -> IO ()
showDynFlags Bool
show_all DynFlags
dflags = do
  Bool -> DynFlags -> IO ()
showLanguages' Bool
show_all DynFlags
dflags
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
     String -> MsgDoc
text String
"GHCi-specific dynamic flag settings:" MsgDoc -> MsgDoc -> MsgDoc
$$
         Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((FlagSpec GeneralFlag -> MsgDoc)
-> [FlagSpec GeneralFlag] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> String
-> (GeneralFlag -> DynFlags -> Bool)
-> FlagSpec GeneralFlag
-> MsgDoc
forall flag.
String
-> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting String
"-f" String
"-fno-" GeneralFlag -> DynFlags -> Bool
gopt) [FlagSpec GeneralFlag]
ghciFlags))
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
     String -> MsgDoc
text String
"other dynamic, non-language, flag settings:" MsgDoc -> MsgDoc -> MsgDoc
$$
         Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((FlagSpec GeneralFlag -> MsgDoc)
-> [FlagSpec GeneralFlag] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> String
-> (GeneralFlag -> DynFlags -> Bool)
-> FlagSpec GeneralFlag
-> MsgDoc
forall flag.
String
-> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting String
"-f" String
"-fno-" GeneralFlag -> DynFlags -> Bool
gopt) [FlagSpec GeneralFlag]
others))
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
     String -> MsgDoc
text String
"warning settings:" MsgDoc -> MsgDoc -> MsgDoc
$$
         Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((FlagSpec WarningFlag -> MsgDoc)
-> [FlagSpec WarningFlag] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> String
-> (WarningFlag -> DynFlags -> Bool)
-> FlagSpec WarningFlag
-> MsgDoc
forall flag.
String
-> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting String
"-W" String
"-Wno-" WarningFlag -> DynFlags -> Bool
wopt) [FlagSpec WarningFlag]
DynFlags.wWarningFlags))
  where
        setting :: String
-> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting String
prefix String
noPrefix flag -> DynFlags -> Bool
test FlagSpec flag
flag
          | Bool
quiet     = MsgDoc
empty
          | Bool
is_on     = String -> MsgDoc
text String
prefix MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
name
          | Bool
otherwise = String -> MsgDoc
text String
noPrefix MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
name
          where name :: String
name = FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
                f :: flag
f = FlagSpec flag -> flag
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec flag
flag
                is_on :: Bool
is_on = flag -> DynFlags -> Bool
test flag
f DynFlags
dflags
                quiet :: Bool
quiet = Bool -> Bool
not Bool
show_all Bool -> Bool -> Bool
&& flag -> DynFlags -> Bool
test flag
f DynFlags
default_dflags Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_on

        default_dflags :: DynFlags
default_dflags = Settings -> LlvmConfig -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags)

        ([FlagSpec GeneralFlag]
ghciFlags,[FlagSpec GeneralFlag]
others)  = (FlagSpec GeneralFlag -> Bool)
-> [FlagSpec GeneralFlag]
-> ([FlagSpec GeneralFlag], [FlagSpec GeneralFlag])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\FlagSpec GeneralFlag
f -> FlagSpec GeneralFlag -> GeneralFlag
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec GeneralFlag
f GeneralFlag -> [GeneralFlag] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [GeneralFlag]
flgs)
                                        [FlagSpec GeneralFlag]
DynFlags.fFlags
        flgs :: [GeneralFlag]
flgs = [ GeneralFlag
Opt_PrintExplicitForalls
               , GeneralFlag
Opt_PrintExplicitKinds
               , GeneralFlag
Opt_PrintUnicodeSyntax
               , GeneralFlag
Opt_PrintBindResult
               , GeneralFlag
Opt_BreakOnException
               , GeneralFlag
Opt_BreakOnError
               , GeneralFlag
Opt_PrintEvldWithShow
               ]

setArgs, setOptions :: GhciMonad m => [String] -> m ()
setProg, setEditor, setStop :: GhciMonad m => String -> m ()
setLocalConfigBehaviour :: GhciMonad m => String -> m ()

setArgs :: [String] -> m ()
setArgs [String]
args = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  ForeignHValue
wrapper <- String -> [String] -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
String -> [String] -> m ForeignHValue
mkEvalWrapper (GHCiState -> String
progname GHCiState
st) [String]
args
  GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st { args :: [String]
GhciMonad.args = [String]
args, evalWrapper :: ForeignHValue
evalWrapper = ForeignHValue
wrapper }

setProg :: String -> m ()
setProg String
prog = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  ForeignHValue
wrapper <- String -> [String] -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
String -> [String] -> m ForeignHValue
mkEvalWrapper String
prog (GHCiState -> [String]
GhciMonad.args GHCiState
st)
  GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st { progname :: String
progname = String
prog, evalWrapper :: ForeignHValue
evalWrapper = ForeignHValue
wrapper }

setEditor :: String -> m ()
setEditor String
cmd = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { editor :: String
editor = String
cmd })

setLocalConfigBehaviour :: String -> m ()
setLocalConfigBehaviour String
s
  | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"source" =
      (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { localConfig :: LocalConfigBehaviour
localConfig = LocalConfigBehaviour
SourceLocalConfig })
  | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ignore" =
      (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { localConfig :: LocalConfigBehaviour
localConfig = LocalConfigBehaviour
IgnoreLocalConfig })
  | Bool
otherwise = GhcException -> m ()
forall a. GhcException -> a
throwGhcException
      (String -> GhcException
CmdLineError String
"syntax:  :set local-config { source | ignore }")

setStop :: String -> m ()
setStop str :: String
str@(Char
c:String
_) | Char -> Bool
isDigit Char
c
  = do let (String
nm_str,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isDigit) String
str
           nm :: Int
nm = String -> Int
forall a. Read a => String -> a
read String
nm_str
       GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
       let old_breaks :: IntMap BreakLocation
old_breaks = GHCiState -> IntMap BreakLocation
breaks GHCiState
st
       case Int -> IntMap BreakLocation -> Maybe BreakLocation
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
nm IntMap BreakLocation
old_breaks of
         Maybe BreakLocation
Nothing ->  MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (String -> MsgDoc
text String
"Breakpoint" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int
nm MsgDoc -> MsgDoc -> MsgDoc
<+>
                                   String -> MsgDoc
text String
"does not exist")
         Just BreakLocation
loc -> do
            let new_breaks :: IntMap BreakLocation
new_breaks = Int
-> BreakLocation -> IntMap BreakLocation -> IntMap BreakLocation
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
nm
                                BreakLocation
loc { onBreakCmd :: String
onBreakCmd = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest }
                                IntMap BreakLocation
old_breaks
            GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{ breaks :: IntMap BreakLocation
breaks = IntMap BreakLocation
new_breaks }
setStop String
cmd = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { stop :: String
stop = String
cmd })

setPrompt :: GhciMonad m => PromptFunction -> m ()
setPrompt :: PromptFunction -> m ()
setPrompt PromptFunction
v = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st {prompt :: PromptFunction
prompt = PromptFunction
v})

setPromptCont :: GhciMonad m => PromptFunction -> m ()
setPromptCont :: PromptFunction -> m ()
setPromptCont PromptFunction
v = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st {prompt_cont :: PromptFunction
prompt_cont = PromptFunction
v})

setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()
setPromptFunc :: (PromptFunction -> m ()) -> String -> m ()
setPromptFunc PromptFunction -> m ()
fSetPrompt String
s = do
    -- We explicitly annotate the type of the expression to ensure
    -- that unsafeCoerce# is passed the exact type necessary rather
    -- than a more general one
    let exprStr :: String
exprStr = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") :: [String] -> Int -> IO String"
    (HValue Any
funValue) <- String -> m HValue
forall (m :: Type -> Type). GhcMonad m => String -> m HValue
GHC.compileExpr String
exprStr
    PromptFunction -> m ()
fSetPrompt (([String] -> Int -> IO String) -> PromptFunction
convertToPromptFunction (([String] -> Int -> IO String) -> PromptFunction)
-> ([String] -> Int -> IO String) -> PromptFunction
forall a b. (a -> b) -> a -> b
$ Any -> [String] -> Int -> IO String
forall a b. a -> b
unsafeCoerce Any
funValue)
    where
      convertToPromptFunction :: ([String] -> Int -> IO String)
                              -> PromptFunction
      convertToPromptFunction :: ([String] -> Int -> IO String) -> PromptFunction
convertToPromptFunction [String] -> Int -> IO String
func = (\[String]
mods Int
line -> IO MsgDoc -> GHCi MsgDoc
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO MsgDoc -> GHCi MsgDoc) -> IO MsgDoc -> GHCi MsgDoc
forall a b. (a -> b) -> a -> b
$
                                       (String -> MsgDoc) -> IO String -> IO MsgDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM String -> MsgDoc
text ([String] -> Int -> IO String
func [String]
mods Int
line))

setPromptString :: MonadIO m
                => (PromptFunction -> m ()) -> String -> String -> m ()
setPromptString :: (PromptFunction -> m ()) -> String -> String -> m ()
setPromptString PromptFunction -> m ()
fSetPrompt String
value String
err = do
  if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
value
    then IO () -> m ()
forall (m :: Type -> Type) 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
err
    else case String
value of
           (Char
'\"':String
_) ->
             case ReadS String
forall a. Read a => ReadS a
reads String
value of
               [(String
value', String
xs)] | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
xs ->
                 (PromptFunction -> m ()) -> String -> m ()
forall (m :: Type -> Type).
MonadIO m =>
(PromptFunction -> m ()) -> String -> m ()
setParsedPromptString PromptFunction -> m ()
fSetPrompt String
value'
               [(String, String)]
_ -> IO () -> m ()
forall (m :: Type -> Type) 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
"Can't parse prompt string. Use Haskell syntax."
           String
_ ->
             (PromptFunction -> m ()) -> String -> m ()
forall (m :: Type -> Type).
MonadIO m =>
(PromptFunction -> m ()) -> String -> m ()
setParsedPromptString PromptFunction -> m ()
fSetPrompt String
value

setParsedPromptString :: MonadIO m
                      => (PromptFunction -> m ()) ->  String -> m ()
setParsedPromptString :: (PromptFunction -> m ()) -> String -> m ()
setParsedPromptString PromptFunction -> m ()
fSetPrompt String
s = do
  case (String -> Maybe String
checkPromptStringForErrors String
s) of
    Just String
err ->
      IO () -> m ()
forall (m :: Type -> Type) 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
err
    Maybe String
Nothing ->
      PromptFunction -> m ()
fSetPrompt (PromptFunction -> m ()) -> PromptFunction -> m ()
forall a b. (a -> b) -> a -> b
$ String -> PromptFunction
generatePromptFunctionFromString String
s

setOptions :: [String] -> m ()
setOptions [String]
wds =
   do -- first, deal with the GHCi opts (+s, +t, etc.)
      let ([String]
plus_opts, [String]
minus_opts)  = (String -> Either String String)
-> [String] -> ([String], [String])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith String -> Either String String
isPlus [String]
wds
      (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setOpt [String]
plus_opts
      -- then, dynamic flags
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
minus_opts)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [String] -> m ()
newDynFlags Bool
False [String]
minus_opts

newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
newDynFlags :: Bool -> [String] -> m ()
newDynFlags Bool
interactive_only [String]
minus_opts = do
      let lopts :: [Located String]
lopts = (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [String]
minus_opts

      DynFlags
idflags0 <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags
      (DynFlags
idflags1, [Located String]
leftovers, [Warn]
warns) <- DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags DynFlags
idflags0 [Located String]
lopts

      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
idflags1 [Warn]
warns
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Located String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Located String]
leftovers)
           (GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ())
-> (String -> GhcException) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError
            (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Some flags have not been recognized: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located String]
leftovers))

      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool
interactive_only Bool -> Bool -> Bool
&& DynFlags -> DynFlags -> Bool
packageFlagsChanged DynFlags
idflags1 DynFlags
idflags0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          IO () -> m ()
forall (m :: Type -> Type) 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
"cannot set package flags with :seti; use :set"
      -- Load any new plugins
      HscEnv
hsc_env0 <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
      DynFlags
idflags2 <- IO DynFlags -> m DynFlags
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env0 DynFlags
idflags1)
      DynFlags -> m ()
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
idflags2
      Maybe String -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Maybe String -> Bool -> m ()
installInteractivePrint (DynFlags -> Maybe String
interactivePrint DynFlags
idflags1) Bool
False

      DynFlags
dflags0 <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags

      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
interactive_only) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        (DynFlags
dflags1, [Located String]
_, [Warn]
_) <- IO (DynFlags, [Located String], [Warn])
-> m (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
 -> m (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> m (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags DynFlags
dflags0 [Located String]
lopts
        [InstalledUnitId]
new_pkgs <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setProgramDynFlags DynFlags
dflags1

        -- if the package flags changed, reset the context and link
        -- the new packages.
        HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
        let dflags2 :: DynFlags
dflags2 = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DynFlags -> DynFlags -> Bool
packageFlagsChanged DynFlags
dflags2 DynFlags
dflags0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
dflags2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
              String
"package flags have changed, resetting and loading new packages..."
          -- delete targets and all eventually defined breakpoints. (#1620)
          m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearAllTargets
          IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [InstalledUnitId] -> IO ()
linkPackages HscEnv
hsc_env [InstalledUnitId]
new_pkgs
          -- package flags changed, we can't re-use any of the old context
          Bool -> [ModSummary] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [ModSummary] -> m ()
setContextAfterLoad Bool
False []
          -- and copy the package state to the interactive DynFlags
          DynFlags
idflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags
          DynFlags -> m ()
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags
              DynFlags
idflags{ pkgState :: PackageState
pkgState = DynFlags -> PackageState
pkgState DynFlags
dflags2
                     , pkgDatabase :: Maybe
  [(String,
    [InstalledPackageInfo
       ComponentId
       SourcePackageId
       PackageName
       InstalledUnitId
       UnitId
       ModuleName
       Module])]
pkgDatabase = DynFlags
-> Maybe
     [(String,
       [InstalledPackageInfo
          ComponentId
          SourcePackageId
          PackageName
          InstalledUnitId
          UnitId
          ModuleName
          Module])]
pkgDatabase DynFlags
dflags2
                     , packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags2 }

        let ld0length :: Int
ld0length   = [Option] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([Option] -> Int) -> [Option] -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option]
ldInputs DynFlags
dflags0
            fmrk0length :: Int
fmrk0length = [String] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
cmdlineFrameworks DynFlags
dflags0

            newLdInputs :: [Option]
newLdInputs     = Int -> [Option] -> [Option]
forall a. Int -> [a] -> [a]
drop Int
ld0length (DynFlags -> [Option]
ldInputs DynFlags
dflags2)
            newCLFrameworks :: [String]
newCLFrameworks = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
fmrk0length (DynFlags -> [String]
cmdlineFrameworks DynFlags
dflags2)

            hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags =
                         DynFlags
dflags2 { ldInputs :: [Option]
ldInputs = [Option]
newLdInputs
                                 , cmdlineFrameworks :: [String]
cmdlineFrameworks = [String]
newCLFrameworks } }

        Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Option] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Option]
newLdInputs Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
newCLFrameworks)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
linkCmdLineLibs HscEnv
hsc_env'

      () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()


unsetOptions :: GhciMonad m => String -> m ()
unsetOptions :: String -> m ()
unsetOptions String
str
  =   -- first, deal with the GHCi opts (+s, +t, etc.)
     let opts :: [String]
opts = String -> [String]
words String
str
         ([String]
minus_opts, [String]
rest1) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
isMinus [String]
opts
         ([String]
plus_opts, [String]
rest2)  = (String -> Either String String)
-> [String] -> ([String], [String])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith String -> Either String String
isPlus [String]
rest1
         ([String]
other_opts, [String]
rest3) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> [String] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ((String, m ()) -> String) -> [(String, m ())] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, m ()) -> String
forall a b. (a, b) -> a
fst [(String, m ())]
defaulters) [String]
rest2

         defaulters :: [(String, m ())]
defaulters =
           [ (String
"args"   , [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
setArgs [String]
default_args)
           , (String
"prog"   , String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setProg String
default_progname)
           , (String
"prompt"     , PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPrompt PromptFunction
default_prompt)
           , (String
"prompt-cont", PromptFunction -> m ()
forall (m :: Type -> Type). GhciMonad m => PromptFunction -> m ()
setPromptCont PromptFunction
default_prompt_cont)
           , (String
"editor" , IO String -> m String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO String
findEditor m String -> (String -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setEditor)
           , (String
"stop"   , String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
setStop String
default_stop)
           ]

         no_flag :: String -> m String
no_flag (Char
'-':Char
'f':String
rest) = String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
"-fno-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
         no_flag (Char
'-':Char
'X':String
rest) = String -> m String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
"-XNo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
         no_flag String
f = GhcException -> m String
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError (String
"don't know how to reverse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f))

     in if (Bool -> Bool
not ([String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
rest3))
           then IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String
"unknown option: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
rest3 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"))
           else do
             (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe (m ()) -> m ()
forall a. HasCallStack => Maybe a -> a
fromJust(Maybe (m ()) -> m ())
-> (String -> Maybe (m ())) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String -> [(String, m ())] -> Maybe (m ()))
-> [(String, m ())] -> String -> Maybe (m ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [(String, m ())] -> Maybe (m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(String, m ())]
defaulters) [String]
other_opts

             (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
unsetOpt [String]
plus_opts

             [String]
no_flags <- (String -> m String) -> [String] -> m [String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m String
forall (m :: Type -> Type). Monad m => String -> m String
no_flag [String]
minus_opts
             Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
no_flags)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [String] -> m ()
newDynFlags Bool
False [String]
no_flags

isMinus :: String -> Bool
isMinus :: String -> Bool
isMinus (Char
'-':String
_) = Bool
True
isMinus String
_ = Bool
False

isPlus :: String -> Either String String
isPlus :: String -> Either String String
isPlus (Char
'+':String
opt) = String -> Either String String
forall a b. a -> Either a b
Left String
opt
isPlus String
other     = String -> Either String String
forall a b. b -> Either a b
Right String
other

setOpt, unsetOpt :: GhciMonad m => String -> m ()

setOpt :: String -> m ()
setOpt String
str
  = case String -> Maybe GHCiOption
strToGHCiOpt String
str of
        Maybe GHCiOption
Nothing -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String
"unknown option: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"))
        Just GHCiOption
o  -> GHCiOption -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m ()
setOption GHCiOption
o

unsetOpt :: String -> m ()
unsetOpt String
str
  = case String -> Maybe GHCiOption
strToGHCiOpt String
str of
        Maybe GHCiOption
Nothing -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String
"unknown option: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"))
        Just GHCiOption
o  -> GHCiOption -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiOption -> m ()
unsetOption GHCiOption
o

strToGHCiOpt :: String -> (Maybe GHCiOption)
strToGHCiOpt :: String -> Maybe GHCiOption
strToGHCiOpt String
"m" = GHCiOption -> Maybe GHCiOption
forall a. a -> Maybe a
Just GHCiOption
Multiline
strToGHCiOpt String
"s" = GHCiOption -> Maybe GHCiOption
forall a. a -> Maybe a
Just GHCiOption
ShowTiming
strToGHCiOpt String
"t" = GHCiOption -> Maybe GHCiOption
forall a. a -> Maybe a
Just GHCiOption
ShowType
strToGHCiOpt String
"r" = GHCiOption -> Maybe GHCiOption
forall a. a -> Maybe a
Just GHCiOption
RevertCAFs
strToGHCiOpt String
"c" = GHCiOption -> Maybe GHCiOption
forall a. a -> Maybe a
Just GHCiOption
CollectInfo
strToGHCiOpt String
_   = Maybe GHCiOption
forall a. Maybe a
Nothing

optToStr :: GHCiOption -> String
optToStr :: GHCiOption -> String
optToStr GHCiOption
Multiline  = String
"m"
optToStr GHCiOption
ShowTiming = String
"s"
optToStr GHCiOption
ShowType   = String
"t"
optToStr GHCiOption
RevertCAFs = String
"r"
optToStr GHCiOption
CollectInfo = String
"c"


-- ---------------------------------------------------------------------------
-- :show

showCmd :: forall m. GhciMonad m => String -> m ()
showCmd :: String -> m ()
showCmd String
""   = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
False
showCmd String
"-a" = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
True
showCmd String
str = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession

    let lookupCmd :: String -> Maybe (m ())
        lookupCmd :: String -> Maybe (m ())
lookupCmd String
name = String -> [(String, m ())] -> Maybe (m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name ([(String, m ())] -> Maybe (m ()))
-> [(String, m ())] -> Maybe (m ())
forall a b. (a -> b) -> a -> b
$ ((Bool, String, m ()) -> (String, m ()))
-> [(Bool, String, m ())] -> [(String, m ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_,String
b,m ()
c) -> (String
b,m ()
c)) [(Bool, String, m ())]
cmds

        -- (show in help?, command name, action)
        action :: String -> m () -> (Bool, String, m ())
        action :: String -> m () -> (Bool, String, m ())
action String
name m ()
m = (Bool
True, String
name, m ()
m)

        hidden :: String -> m () -> (Bool, String, m ())
        hidden :: String -> m () -> (Bool, String, m ())
hidden String
name m ()
m = (Bool
False, String
name, m ()
m)

        cmds :: [(Bool, String, m ())]
cmds =
            [ String -> m () -> (Bool, String, m ())
action String
"args"       (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ([String] -> String
forall a. Show a => a -> String
show (GHCiState -> [String]
GhciMonad.args GHCiState
st))
            , String -> m () -> (Bool, String, m ())
action String
"prog"       (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> String
forall a. Show a => a -> String
show (GHCiState -> String
progname GHCiState
st))
            , String -> m () -> (Bool, String, m ())
action String
"editor"     (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> String
forall a. Show a => a -> String
show (GHCiState -> String
editor GHCiState
st))
            , String -> m () -> (Bool, String, m ())
action String
"stop"       (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> String
forall a. Show a => a -> String
show (GHCiState -> String
stop GHCiState
st))
            , String -> m () -> (Bool, String, m ())
action String
"imports"    (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhciMonad m => m ()
showImports
            , String -> m () -> (Bool, String, m ())
action String
"modules"    (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showModules
            , String -> m () -> (Bool, String, m ())
action String
"bindings"   (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showBindings
            , String -> m () -> (Bool, String, m ())
action String
"linker"     (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynLinker -> DynFlags -> IO ()
showLinkerState (HscEnv -> DynLinker
hsc_dynLinker HscEnv
hsc_env))
            , String -> m () -> (Bool, String, m ())
action String
"breaks"     (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhciMonad m => m ()
showBkptTable
            , String -> m () -> (Bool, String, m ())
action String
"context"    (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showContext
            , String -> m () -> (Bool, String, m ())
action String
"packages"   (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showPackages
            , String -> m () -> (Bool, String, m ())
action String
"paths"      (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showPaths
            , String -> m () -> (Bool, String, m ())
action String
"language"   (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages
            , String -> m () -> (Bool, String, m ())
hidden String
"languages"  (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages -- backwards compat
            , String -> m () -> (Bool, String, m ())
hidden String
"lang"       (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages -- useful abbreviation
            , String -> m () -> (Bool, String, m ())
action String
"targets"    (m () -> (Bool, String, m ())) -> m () -> (Bool, String, m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showTargets
            ]

    case String -> [String]
words String
str of
      [String
w] | Just m ()
action <- String -> Maybe (m ())
lookupCmd String
w -> m ()
action

      [String]
_ -> let helpCmds :: [MsgDoc]
helpCmds = [ String -> MsgDoc
text String
name | (Bool
True, String
name, m ()
_) <- [(Bool, String, m ())]
cmds ]
           in GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags
              (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"syntax:") Int
4
              (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
":show") Int
6
              (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc -> MsgDoc
brackets ([MsgDoc] -> MsgDoc
fsep ([MsgDoc] -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate (String -> MsgDoc
text String
" |") [MsgDoc]
helpCmds)

showiCmd :: GHC.GhcMonad m => String -> m ()
showiCmd :: String -> m ()
showiCmd String
str = do
  case String -> [String]
words String
str of
        [String
"languages"]  -> m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showiLanguages -- backwards compat
        [String
"language"]   -> m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showiLanguages
        [String
"lang"]       -> m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showiLanguages -- useful abbreviation
        [String]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"syntax:  :showi language"))

showImports :: GhciMonad m => m ()
showImports :: m ()
showImports = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  let rem_ctx :: [InteractiveImport]
rem_ctx   = [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a]
reverse (GHCiState -> [InteractiveImport]
remembered_ctx GHCiState
st)
      trans_ctx :: [InteractiveImport]
trans_ctx = GHCiState -> [InteractiveImport]
transient_ctx GHCiState
st

      show_one :: InteractiveImport -> String
show_one (IIModule ModuleName
star_m)
          = String
":module +*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
star_m
      show_one (IIDecl ImportDecl GhcPs
imp) = DynFlags -> ImportDecl GhcPs -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags ImportDecl GhcPs
imp

  [InteractiveImport]
prel_iidecls <- [InteractiveImport] -> m [InteractiveImport]
forall (m :: Type -> Type).
GhciMonad m =>
[InteractiveImport] -> m [InteractiveImport]
getImplicitPreludeImports ([InteractiveImport]
rem_ctx [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
trans_ctx)

  let show_prel :: InteractiveImport -> String
show_prel InteractiveImport
p = InteractiveImport -> String
show_one InteractiveImport
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- implicit"
      show_extra :: ImportDecl GhcPs -> String
show_extra ImportDecl GhcPs
p = InteractiveImport -> String
show_one (ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- fixed"

      trans_comment :: String -> String
trans_comment String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- added automatically" :: String
  --
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ((InteractiveImport -> String) -> [InteractiveImport] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InteractiveImport -> String
show_one [InteractiveImport]
rem_ctx [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                           (InteractiveImport -> String) -> [InteractiveImport] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
trans_comment (String -> String)
-> (InteractiveImport -> String) -> InteractiveImport -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InteractiveImport -> String
show_one) [InteractiveImport]
trans_ctx [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                           (InteractiveImport -> String) -> [InteractiveImport] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InteractiveImport -> String
show_prel [InteractiveImport]
prel_iidecls [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                           (ImportDecl GhcPs -> String) -> [ImportDecl GhcPs] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> String
show_extra (GHCiState -> [ImportDecl GhcPs]
extra_imports GHCiState
st))

showModules :: GHC.GhcMonad m => m ()
showModules :: m ()
showModules = do
  [ModSummary]
loaded_mods <- m [ModSummary]
forall (m :: Type -> Type). GhcMonad m => m [ModSummary]
getLoadedModules
        -- we want *loaded* modules only, see #1734
  let show_one :: ModSummary -> m ()
show_one ModSummary
ms = do String
m <- ModSummary -> m String
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m String
GHC.showModule ModSummary
ms; IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn String
m)
  (ModSummary -> m ()) -> [ModSummary] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ModSummary -> m ()
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m ()
show_one [ModSummary]
loaded_mods

getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
getLoadedModules :: m [ModSummary]
getLoadedModules = do
  ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
  (ModSummary -> m Bool) -> [ModSummary] -> m [ModSummary]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (ModuleName -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded (ModuleName -> m Bool)
-> (ModSummary -> ModuleName) -> ModSummary -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModuleName
GHC.ms_mod_name) (ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph)

showBindings :: GHC.GhcMonad m => m ()
showBindings :: m ()
showBindings = do
    [TyThing]
bindings <- m [TyThing]
forall (m :: Type -> Type). GhcMonad m => m [TyThing]
GHC.getBindings
    ([ClsInst]
insts, [FamInst]
finsts) <- m ([ClsInst], [FamInst])
forall (m :: Type -> Type). GhcMonad m => m ([ClsInst], [FamInst])
GHC.getInsts
    let idocs :: [MsgDoc]
idocs  = (ClsInst -> MsgDoc) -> [ClsInst] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> MsgDoc
GHC.pprInstanceHdr [ClsInst]
insts
        fidocs :: [MsgDoc]
fidocs = (FamInst -> MsgDoc) -> [FamInst] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> MsgDoc
GHC.pprFamInst [FamInst]
finsts
        binds :: [TyThing]
binds = (TyThing -> Bool) -> [TyThing] -> [TyThing]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyThing -> Bool) -> TyThing -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> Bool
isDerivedOccName (OccName -> Bool) -> (TyThing -> OccName) -> TyThing -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName) [TyThing]
bindings -- #12525
        -- See Note [Filter bindings]
    [MsgDoc]
docs <- (TyThing -> m MsgDoc) -> [TyThing] -> m [MsgDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyThing -> m MsgDoc
forall (m :: Type -> Type). GhcMonad m => TyThing -> m MsgDoc
makeDoc ([TyThing] -> [TyThing]
forall a. [a] -> [a]
reverse [TyThing]
binds)
                  -- reverse so the new ones come last
    (MsgDoc -> m ()) -> [MsgDoc] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUserPartWay ([MsgDoc]
docs [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a. [a] -> [a] -> [a]
++ [MsgDoc]
idocs [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a. [a] -> [a] -> [a]
++ [MsgDoc]
fidocs)
  where
    makeDoc :: TyThing -> m MsgDoc
makeDoc (AnId Id
i) = Id -> m MsgDoc
forall (m :: Type -> Type). GhcMonad m => Id -> m MsgDoc
pprTypeAndContents Id
i
    makeDoc TyThing
tt = do
        Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
mb_stuff <- Bool
-> Name
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
forall (m :: Type -> Type).
GhcMonad m =>
Bool
-> Name
-> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc))
GHC.getInfo Bool
False (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tt)
        MsgDoc -> m MsgDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MsgDoc -> m MsgDoc) -> MsgDoc -> m MsgDoc
forall a b. (a -> b) -> a -> b
$ MsgDoc
-> ((TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc)
-> Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
-> MsgDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> MsgDoc
text String
"") (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc
pprTT Maybe (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc)
mb_stuff

    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
    pprTT :: (TyThing, Fixity, [ClsInst], [FamInst], MsgDoc) -> MsgDoc
pprTT (TyThing
thing, Fixity
fixity, [ClsInst]
_cls_insts, [FamInst]
_fam_insts, MsgDoc
_docs)
      = ShowSub -> TyThing -> MsgDoc
pprTyThing ShowSub
showToHeader TyThing
thing
        MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
show_fixity
      where
        show_fixity :: MsgDoc
show_fixity
            | Fixity
fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
GHC.defaultFixity  = MsgDoc
empty
            | Bool
otherwise                    = Fixity -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Fixity
fixity MsgDoc -> MsgDoc -> MsgDoc
<+> Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
thing)


printTyThing :: GHC.GhcMonad m => TyThing -> m ()
printTyThing :: TyThing -> m ()
printTyThing TyThing
tyth = MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (ShowSub -> TyThing -> MsgDoc
pprTyThing ShowSub
showToHeader TyThing
tyth)

{-
Note [Filter bindings]
~~~~~~~~~~~~~~~~~~~~~~

If we don't filter the bindings returned by the function GHC.getBindings,
then the :show bindings command will also show unwanted bound names,
internally generated by GHC, eg:
    $tcFoo :: GHC.Types.TyCon = _
    $trModule :: GHC.Types.Module = _ .

The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this
ticket contains an analysis of the situation and suggests the solution
implemented above.

The same filter was also implemented to fix #11051 [3]. See the
Note [What to show to users] in compiler/main/InteractiveEval.hs

[1] https://gitlab.haskell.org/ghc/ghc/issues/12525
[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489
[3] https://gitlab.haskell.org/ghc/ghc/issues/11051
-}


showBkptTable :: GhciMonad m => m ()
showBkptTable :: m ()
showBkptTable = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ IntMap BreakLocation -> MsgDoc
prettyLocations (GHCiState -> IntMap BreakLocation
breaks GHCiState
st)

showContext :: GHC.GhcMonad m => m ()
showContext :: m ()
showContext = do
   [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
   MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat ((Resume -> MsgDoc) -> [Resume] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map Resume -> MsgDoc
pp_resume ([Resume] -> [Resume]
forall a. [a] -> [a]
reverse [Resume]
resumes))
  where
   pp_resume :: Resume -> MsgDoc
pp_resume Resume
res =
        PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"--> ") MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text (Resume -> String
GHC.resumeStmt Resume
res)
        MsgDoc -> MsgDoc -> MsgDoc
$$ Int -> MsgDoc -> MsgDoc
nest Int
2 (Resume -> MsgDoc
pprStopped Resume
res)

pprStopped :: GHC.Resume -> SDoc
pprStopped :: Resume -> MsgDoc
pprStopped Resume
res =
  PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"Stopped in")
    MsgDoc -> MsgDoc -> MsgDoc
<+> ((case Maybe ModuleName
mb_mod_name of
           Maybe ModuleName
Nothing -> MsgDoc
empty
           Just ModuleName
mod_name -> String -> MsgDoc
text (ModuleName -> String
moduleNameString ModuleName
mod_name) MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
'.')
         MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text (Resume -> String
GHC.resumeDecl Resume
res))
    MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
',' MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (Resume -> SrcSpan
GHC.resumeSpan Resume
res)
 where
  mb_mod_name :: Maybe ModuleName
mb_mod_name = Module -> ModuleName
moduleName (Module -> ModuleName)
-> (BreakInfo -> Module) -> BreakInfo -> ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> BreakInfo -> Module
GHC.breakInfo_module (BreakInfo -> ModuleName) -> Maybe BreakInfo -> Maybe ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Resume -> Maybe BreakInfo
GHC.resumeBreakInfo Resume
res

showPackages :: GHC.GhcMonad m => m ()
showPackages :: m ()
showPackages = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  let pkg_flags :: [PackageFlag]
pkg_flags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
    String -> MsgDoc
text (String
"active package flags:"String -> String -> String
forall a. [a] -> [a] -> [a]
++if [PackageFlag] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [PackageFlag]
pkg_flags then String
" none" else String
"") MsgDoc -> MsgDoc -> MsgDoc
$$
      Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((PackageFlag -> MsgDoc) -> [PackageFlag] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> MsgDoc
pprFlag [PackageFlag]
pkg_flags))

showPaths :: GHC.GhcMonad m => m ()
showPaths :: m ()
showPaths = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String
cwd <- IO String
getCurrentDirectory
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
      String -> MsgDoc
text String
"current working directory: " MsgDoc -> MsgDoc -> MsgDoc
$$
        Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
cwd)
    let ipaths :: [String]
ipaths = DynFlags -> [String]
importPaths DynFlags
dflags
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
      String -> MsgDoc
text (String
"module import search paths:"String -> String -> String
forall a. [a] -> [a] -> [a]
++if [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
ipaths then String
" none" else String
"") MsgDoc -> MsgDoc -> MsgDoc
$$
        Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text [String]
ipaths))

showLanguages :: GHC.GhcMonad m => m ()
showLanguages :: m ()
showLanguages = m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DynFlags -> IO ()
showLanguages' Bool
False

showiLanguages :: GHC.GhcMonad m => m ()
showiLanguages :: m ()
showiLanguages = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (DynFlags -> IO ()) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DynFlags -> IO ()
showLanguages' Bool
False

showLanguages' :: Bool -> DynFlags -> IO ()
showLanguages' :: Bool -> DynFlags -> IO ()
showLanguages' Bool
show_all DynFlags
dflags =
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat
     [ String -> MsgDoc
text String
"base language is: " MsgDoc -> MsgDoc -> MsgDoc
<>
         case DynFlags -> Maybe Language
language DynFlags
dflags of
           Maybe Language
Nothing          -> String -> MsgDoc
text String
"Haskell2010"
           Just Language
Haskell98   -> String -> MsgDoc
text String
"Haskell98"
           Just Language
Haskell2010 -> String -> MsgDoc
text String
"Haskell2010"
     , (if Bool
show_all then String -> MsgDoc
text String
"all active language options:"
                    else String -> MsgDoc
text String
"with the following modifiers:") MsgDoc -> MsgDoc -> MsgDoc
$$
          Int -> MsgDoc -> MsgDoc
nest Int
2 ([MsgDoc] -> MsgDoc
vcat ((FlagSpec Extension -> MsgDoc) -> [FlagSpec Extension] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((Extension -> DynFlags -> Bool) -> FlagSpec Extension -> MsgDoc
forall flag. (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting Extension -> DynFlags -> Bool
xopt) [FlagSpec Extension]
DynFlags.xFlags))
     ]
  where
   setting :: (flag -> DynFlags -> Bool) -> FlagSpec flag -> MsgDoc
setting flag -> DynFlags -> Bool
test FlagSpec flag
flag
          | Bool
quiet     = MsgDoc
empty
          | Bool
is_on     = String -> MsgDoc
text String
"-X" MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
name
          | Bool
otherwise = String -> MsgDoc
text String
"-XNo" MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
name
          where name :: String
name = FlagSpec flag -> String
forall flag. FlagSpec flag -> String
flagSpecName FlagSpec flag
flag
                f :: flag
f = FlagSpec flag -> flag
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec flag
flag
                is_on :: Bool
is_on = flag -> DynFlags -> Bool
test flag
f DynFlags
dflags
                quiet :: Bool
quiet = Bool -> Bool
not Bool
show_all Bool -> Bool -> Bool
&& flag -> DynFlags -> Bool
test flag
f DynFlags
default_dflags Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_on

   default_dflags :: DynFlags
default_dflags =
       Settings -> LlvmConfig -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags) DynFlags -> Maybe Language -> DynFlags
`lang_set`
         case DynFlags -> Maybe Language
language DynFlags
dflags of
           Maybe Language
Nothing -> Language -> Maybe Language
forall a. a -> Maybe a
Just Language
Haskell2010
           Maybe Language
other   -> Maybe Language
other

showTargets :: GHC.GhcMonad m => m ()
showTargets :: m ()
showTargets = (Target -> m ()) -> [Target] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Target -> m ()
forall (m :: Type -> Type). GhcMonad m => Target -> m ()
showTarget ([Target] -> m ()) -> m [Target] -> m ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< m [Target]
forall (m :: Type -> Type). GhcMonad m => m [Target]
GHC.getTargets
  where
    showTarget :: GHC.GhcMonad m => Target -> m ()
    showTarget :: Target -> m ()
showTarget (Target (TargetFile String
f Maybe Phase
_) Bool
_ Maybe (StringBuffer, UTCTime)
_) = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn String
f)
    showTarget (Target (TargetModule ModuleName
m) Bool
_ Maybe (StringBuffer, UTCTime)
_) =
      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
m)

-- -----------------------------------------------------------------------------
-- Completion

completeCmd :: String -> GHCi ()
completeCmd :: String -> GHCi ()
completeCmd String
argLine0 = case String -> Maybe (String, (Maybe Int, Maybe Int), String)
parseLine String
argLine0 of
    Just (String
"repl", (Maybe Int, Maybe Int)
resultRange, String
left) -> do
        (String
unusedLine,[Completion]
compls) <- CompletionFunc GHCi
ghciCompleteWord (String -> String
forall a. [a] -> [a]
reverse String
left,String
"")
        let compls' :: [Completion]
compls' = (Maybe Int, Maybe Int) -> [Completion] -> [Completion]
forall a. (Maybe Int, Maybe Int) -> [a] -> [a]
takeRange (Maybe Int, Maybe Int)
resultRange [Completion]
compls
        IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> GHCi ()) -> (String -> IO ()) -> String -> GHCi ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> GHCi ()) -> String -> GHCi ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ Int -> String
forall a. Show a => a -> String
show ([Completion] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Completion]
compls'), Int -> String
forall a. Show a => a -> String
show ([Completion] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Completion]
compls), String -> String
forall a. Show a => a -> String
show (String -> String
forall a. [a] -> [a]
reverse String
unusedLine) ]
        [Completion] -> (Completion -> GHCi ()) -> GHCi ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Maybe Int, Maybe Int) -> [Completion] -> [Completion]
forall a. (Maybe Int, Maybe Int) -> [a] -> [a]
takeRange (Maybe Int, Maybe Int)
resultRange [Completion]
compls) ((Completion -> GHCi ()) -> GHCi ())
-> (Completion -> GHCi ()) -> GHCi ()
forall a b. (a -> b) -> a -> b
$ \(Completion String
r String
_ Bool
_) -> do
            IO () -> GHCi ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> GHCi ()) -> IO () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
r
    Maybe (String, (Maybe Int, Maybe Int), String)
_ -> GhcException -> GHCi ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"Syntax: :complete repl [<range>] <quoted-string-to-complete>")
  where
    parseLine :: String -> Maybe (String, (Maybe Int, Maybe Int), String)
parseLine String
argLine
        | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
argLine = Maybe (String, (Maybe Int, Maybe Int), String)
forall a. Maybe a
Nothing
        | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
rest1   = Maybe (String, (Maybe Int, Maybe Int), String)
forall a. Maybe a
Nothing
        | Bool
otherwise    = (,,) String
dom ((Maybe Int, Maybe Int)
 -> String -> (String, (Maybe Int, Maybe Int), String))
-> Maybe (Maybe Int, Maybe Int)
-> Maybe (String -> (String, (Maybe Int, Maybe Int), String))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Int, Maybe Int)
resRange Maybe (String -> (String, (Maybe Int, Maybe Int), String))
-> Maybe String -> Maybe (String, (Maybe Int, Maybe Int), String)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe String
s
      where
        (String
dom, String
rest1) = String -> (String, String)
breakSpace String
argLine
        (String
rng, String
rest2) = String -> (String, String)
breakSpace String
rest1
        resRange :: Maybe (Maybe Int, Maybe Int)
resRange | String -> Char
forall a. [a] -> a
head String
rest1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = String -> Maybe (Maybe Int, Maybe Int)
parseRange String
""
                 | Bool
otherwise         = String -> Maybe (Maybe Int, Maybe Int)
parseRange String
rng
        s :: Maybe String
s | String -> Char
forall a. [a] -> a
head String
rest1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
rest1 :: Maybe String
          | Bool
otherwise         = String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
rest2
        breakSpace :: String -> (String, String)
breakSpace = (String -> String) -> (String, String) -> (String, String)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace

    takeRange :: (Maybe Int, Maybe Int) -> [a] -> [a]
takeRange (Maybe Int
lb,Maybe Int
ub) = ([a] -> [a]) -> (Int -> [a] -> [a]) -> Maybe Int -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int -> [a] -> [a]) -> (Int -> Int) -> Int -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred) Maybe Int
lb ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> (Int -> [a] -> [a]) -> Maybe Int -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Maybe Int
ub

    -- syntax: [n-][m] with semantics "drop (n-1) . take m"
    parseRange :: String -> Maybe (Maybe Int,Maybe Int)
    parseRange :: String -> Maybe (Maybe Int, Maybe Int)
parseRange String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s of
                   (String
_, String
"") ->
                       -- upper limit only
                       (Maybe Int, Maybe Int) -> Maybe (Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (Maybe Int
forall a. Maybe a
Nothing, String -> Maybe Int
forall a. Read a => String -> Maybe a
bndRead String
s)
                   (String
s1, Char
'-' : String
s2)
                    | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s2 ->
                       (Maybe Int, Maybe Int) -> Maybe (Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (String -> Maybe Int
forall a. Read a => String -> Maybe a
bndRead String
s1, String -> Maybe Int
forall a. Read a => String -> Maybe a
bndRead String
s2)
                   (String, String)
_ ->
                       Maybe (Maybe Int, Maybe Int)
forall a. Maybe a
Nothing
      where
        bndRead :: String -> Maybe a
bndRead String
x = if String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
x then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just (String -> a
forall a. Read a => String -> a
read String
x)



completeGhciCommand, completeMacro, completeIdentifier, completeModule,
    completeSetModule, completeSeti, completeShowiOptions,
    completeHomeModule, completeSetOptions, completeShowOptions,
    completeHomeModuleOrFile, completeExpression
    :: GhciMonad m => CompletionFunc m

-- | Provide completions for last word in a given string.
--
-- Takes a tuple of two strings.  First string is a reversed line to be
-- completed.  Second string is likely unused, 'completeCmd' always passes an
-- empty string as second item in tuple.
ghciCompleteWord :: CompletionFunc GHCi
ghciCompleteWord :: CompletionFunc GHCi
ghciCompleteWord line :: (String, String)
line@(String
left,String
_) = case String
firstWord of
    -- If given string starts with `:` colon, and there is only one following
    -- word then provide REPL command completions.  If there is more than one
    -- word complete either filename or builtin ghci commands or macros.
    Char
':':String
cmd     | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
rest     -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeGhciCommand (String, String)
line
                | Bool
otherwise     -> do
                        CompletionFunc GHCi
completion <- String -> GHCi (CompletionFunc GHCi)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (CompletionFunc GHCi)
lookupCompletion String
cmd
                        CompletionFunc GHCi
completion (String, String)
line
    -- If given string starts with `import` keyword provide module name
    -- completions
    String
"import"    -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule (String, String)
line
    -- otherwise provide identifier completions
    String
_           -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression (String, String)
line
  where
    (String
firstWord,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
left
    lookupCompletion :: String -> m (CompletionFunc GHCi)
lookupCompletion (Char
'!':String
_) = CompletionFunc GHCi -> m (CompletionFunc GHCi)
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename
    lookupCompletion String
c = do
        Maybe Command
maybe_cmd <- String -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
String -> m (Maybe Command)
lookupCommand' String
c
        case Maybe Command
maybe_cmd of
            Just Command
cmd -> CompletionFunc GHCi -> m (CompletionFunc GHCi)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Command -> CompletionFunc GHCi
cmdCompletionFunc Command
cmd)
            Maybe Command
Nothing  -> CompletionFunc GHCi -> m (CompletionFunc GHCi)
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename

completeGhciCommand :: CompletionFunc m
completeGhciCommand = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
" " ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [Command]
macros <- GHCiState -> [Command]
ghci_macros (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  [Command]
cmds   <- GHCiState -> [Command]
ghci_commands (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let macro_names :: [String]
macro_names = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> ([Command] -> [String]) -> [Command] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> String) -> [Command] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Command -> String
cmdName ([Command] -> [String]) -> [Command] -> [String]
forall a b. (a -> b) -> a -> b
$ [Command]
macros
  let command_names :: [String]
command_names = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> ([Command] -> [String]) -> [Command] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> String) -> [Command] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Command -> String
cmdName ([Command] -> [String]) -> [Command] -> [String]
forall a b. (a -> b) -> a -> b
$ (Command -> Bool) -> [Command] -> [Command]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Command -> Bool) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> Bool
cmdHidden) [Command]
cmds
  let{ candidates :: [String]
candidates = case String
w of
      Char
':' : Char
':' : String
_ -> (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:) [String]
command_names
      String
_ -> [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
macro_names [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
command_names }
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
`isPrefixOptOf`) [String]
candidates

completeMacro :: CompletionFunc m
completeMacro = (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(String -> m [String]) -> CompletionFunc m
wrapIdentCompleter ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [Command]
cmds <- GHCiState -> [Command]
ghci_macros (GHCiState -> [Command]) -> m GHCiState -> m [Command]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ((Command -> String) -> [Command] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Command -> String
cmdName [Command]
cmds))

completeIdentifier :: CompletionFunc m
completeIdentifier line :: (String, String)
line@(String
left, String
_) =
  -- Note: `left` is a reversed input
  case String
left of
    (Char
x:String
_) | Char -> Bool
isSymbolChar Char
x -> String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter (String
specials String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spaces) String -> m [String]
forall (m :: Type -> Type). GhcMonad m => String -> m [String]
complete (String, String)
line
    String
_                      -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(String -> m [String]) -> CompletionFunc m
wrapIdentCompleter String -> m [String]
forall (m :: Type -> Type). GhcMonad m => String -> m [String]
complete (String, String)
line
  where
    complete :: String -> m [String]
complete String
w = do
      [RdrName]
rdrs <- m [RdrName]
forall (m :: Type -> Type). GhcMonad m => m [RdrName]
GHC.getRdrNamesInScope
      DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
      [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ((RdrName -> String) -> [RdrName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> RdrName -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) [RdrName]
rdrs))

completeModule :: CompletionFunc m
completeModule = (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(String -> m [String]) -> CompletionFunc m
wrapIdentCompleter ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let pkg_mods :: [ModuleName]
pkg_mods = DynFlags -> [ModuleName]
allVisibleModules DynFlags
dflags
  [ModuleName]
loaded_mods <- ([ModSummary] -> [ModuleName]) -> m [ModSummary] -> m [ModuleName]
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
GHC.ms_mod_name) m [ModSummary]
forall (m :: Type -> Type). GhcMonad m => m [ModSummary]
getLoadedModules
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
        ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) ([ModuleName] -> [String]) -> [ModuleName] -> [String]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
loaded_mods [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
pkg_mods

completeSetModule :: CompletionFunc m
completeSetModule = String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
wrapIdentCompleterWithModifier String
"+-" ((Maybe Char -> String -> m [String]) -> CompletionFunc m)
-> (Maybe Char -> String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \Maybe Char
m String
w -> do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  [ModuleName]
modules <- case Maybe Char
m of
    Just Char
'-' -> do
      [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
      [ModuleName] -> m [ModuleName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ (InteractiveImport -> ModuleName)
-> [InteractiveImport] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map InteractiveImport -> ModuleName
iiModuleName [InteractiveImport]
imports
    Maybe Char
_ -> do
      let pkg_mods :: [ModuleName]
pkg_mods = DynFlags -> [ModuleName]
allVisibleModules DynFlags
dflags
      [ModuleName]
loaded_mods <- ([ModSummary] -> [ModuleName]) -> m [ModSummary] -> m [ModuleName]
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
GHC.ms_mod_name) m [ModSummary]
forall (m :: Type -> Type). GhcMonad m => m [ModSummary]
getLoadedModules
      [ModuleName] -> m [ModuleName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
loaded_mods [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
pkg_mods
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) [ModuleName]
modules

completeHomeModule :: CompletionFunc m
completeHomeModule = (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(String -> m [String]) -> CompletionFunc m
wrapIdentCompleter String -> m [String]
forall (m :: Type -> Type). GhcMonad m => String -> m [String]
listHomeModules

listHomeModules :: GHC.GhcMonad m => String -> m [String]
listHomeModules :: String -> m [String]
listHomeModules String
w = do
    ModuleGraph
g <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
    let home_mods :: [ModuleName]
home_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
GHC.ms_mod_name (ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
g)
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
            ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) [ModuleName]
home_mods

completeSetOptions :: CompletionFunc m
completeSetOptions = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
flagWordBreakChars ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
opts)
    where opts :: [String]
opts = String
"args"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"prog"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"prompt"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"prompt-cont"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"prompt-function"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                 String
"prompt-cont-function"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"editor"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"stop"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
flagList
          flagList :: [String]
flagList = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall a. [a] -> a
head ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
allNonDeprecatedFlags

completeSeti :: CompletionFunc m
completeSeti = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
flagWordBreakChars ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
flagList)
    where flagList :: [String]
flagList = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall a. [a] -> a
head ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [[String]]) -> [String] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
allNonDeprecatedFlags

completeShowOptions :: CompletionFunc m
completeShowOptions = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
flagWordBreakChars ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
opts)
    where opts :: [String]
opts = [String
"args", String
"prog", String
"editor", String
"stop",
                     String
"modules", String
"bindings", String
"linker", String
"breaks",
                     String
"context", String
"packages", String
"paths", String
"language", String
"imports"]

completeShowiOptions :: CompletionFunc m
completeShowiOptions = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
flagWordBreakChars ((String -> m [String]) -> CompletionFunc m)
-> (String -> m [String]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
w -> do
  [String] -> m [String]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
w String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String
"language"])

completeHomeModuleOrFile :: CompletionFunc m
completeHomeModuleOrFile = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord Maybe Char
forall a. Maybe a
Nothing String
filenameWordBreakChars
                ((String -> m [Completion]) -> CompletionFunc m)
-> (String -> m [Completion]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ (String -> m [Completion])
-> (String -> m [Completion]) -> String -> m [Completion]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> (a -> m [b]) -> a -> m [b]
unionComplete (([String] -> [Completion]) -> m [String] -> m [Completion]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
simpleCompletion) (m [String] -> m [Completion])
-> (String -> m [String]) -> String -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m [String]
forall (m :: Type -> Type). GhcMonad m => String -> m [String]
listHomeModules)
                            String -> m [Completion]
forall (m :: Type -> Type). MonadIO m => String -> m [Completion]
listFiles

unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
unionComplete :: (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
unionComplete a -> m [b]
f1 a -> m [b]
f2 a
line = do
  [b]
cs1 <- a -> m [b]
f1 a
line
  [b]
cs2 <- a -> m [b]
f2 a
line
  [b] -> m [b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([b]
cs1 [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
cs2)

wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter :: String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
breakChars String -> m [String]
fun = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord Maybe Char
forall a. Maybe a
Nothing String
breakChars
    ((String -> m [Completion]) -> CompletionFunc m)
-> (String -> m [Completion]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ ([String] -> [Completion]) -> m [String] -> m [Completion]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
simpleCompletion ([String] -> [Completion])
-> ([String] -> [String]) -> [String] -> [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort) (m [String] -> m [Completion])
-> (String -> m [String]) -> String -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m [String]
fun

wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m
wrapIdentCompleter :: (String -> m [String]) -> CompletionFunc m
wrapIdentCompleter = String -> (String -> m [String]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter String
word_break_chars

wrapIdentCompleterWithModifier
  :: Monad m
  => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
wrapIdentCompleterWithModifier String
modifChars Maybe Char -> String -> m [String]
fun = Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev Maybe Char
forall a. Maybe a
Nothing String
word_break_chars
    ((String -> String -> m [Completion]) -> CompletionFunc m)
-> (String -> String -> m [Completion]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
rest -> ([String] -> [Completion]) -> m [String] -> m [Completion]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
simpleCompletion ([String] -> [Completion])
-> ([String] -> [String]) -> [String] -> [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort) (m [String] -> m [Completion])
-> (String -> m [String]) -> String -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> String -> m [String]
fun (String -> Maybe Char
getModifier String
rest)
 where
  getModifier :: String -> Maybe Char
getModifier = (Char -> Bool) -> String -> Maybe Char
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (Char -> String -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` String
modifChars)

-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
allVisibleModules :: DynFlags -> [ModuleName]
allVisibleModules :: DynFlags -> [ModuleName]
allVisibleModules DynFlags
dflags = DynFlags -> [ModuleName]
listVisibleModuleNames DynFlags
dflags

completeExpression :: CompletionFunc m
completeExpression = Maybe Char
-> String
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
Maybe Char
-> String
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
completeQuotedWord (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\\') String
"\"" String -> m [Completion]
forall (m :: Type -> Type). MonadIO m => String -> m [Completion]
listFiles
                        CompletionFunc m
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier


-- -----------------------------------------------------------------------------
-- commands for debugger

sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()
sprintCmd :: String -> m ()
sprintCmd = Bool -> Bool -> String -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Bool -> String -> m ()
pprintClosureCommand Bool
False Bool
False
printCmd :: String -> m ()
printCmd  = Bool -> Bool -> String -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Bool -> String -> m ()
pprintClosureCommand Bool
True Bool
False
forceCmd :: String -> m ()
forceCmd  = Bool -> Bool -> String -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> Bool -> String -> m ()
pprintClosureCommand Bool
False Bool
True

stepCmd :: GhciMonad m => String -> m ()
stepCmd :: String -> m ()
stepCmd String
arg = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":step" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
step String
arg
  where
  step :: String -> m ()
step []         = (SrcSpan -> Bool) -> SingleStep -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) SingleStep
GHC.SingleStep
  step String
expression = String -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
String -> SingleStep -> m (Maybe ExecResult)
runStmt String
expression SingleStep
GHC.SingleStep m (Maybe ExecResult) -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

stepLocalCmd :: GhciMonad m => String -> m ()
stepLocalCmd :: String -> m ()
stepLocalCmd String
arg = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":steplocal" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
step String
arg
  where
  step :: String -> m ()
step String
expr
   | Bool -> Bool
not (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
expr) = String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepCmd String
expr
   | Bool
otherwise = do
      Maybe SrcSpan
mb_span <- m (Maybe SrcSpan)
forall (m :: Type -> Type). GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan
      case Maybe SrcSpan
mb_span of
        Maybe SrcSpan
Nothing  -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepCmd []
        Just (UnhelpfulSpan FastString
_) -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (            -- #14690
           String
":steplocal is not possible." String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
"\nCannot determine current top-level binding after " String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
"a break on error / exception.\nUse :stepmodule.")
        Just SrcSpan
loc -> do
           Module
md <- Module -> Maybe Module -> Module
forall a. a -> Maybe a -> a
fromMaybe (String -> Module
forall a. String -> a
panic String
"stepLocalCmd") (Maybe Module -> Module) -> m (Maybe Module) -> m Module
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe Module)
forall (m :: Type -> Type). GhcMonad m => m (Maybe Module)
getCurrentBreakModule
           RealSrcSpan
current_toplevel_decl <- Module -> SrcSpan -> m RealSrcSpan
forall (m :: Type -> Type).
GhciMonad m =>
Module -> SrcSpan -> m RealSrcSpan
enclosingTickSpan Module
md SrcSpan
loc
           (SrcSpan -> Bool) -> SingleStep -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue (SrcSpan -> SrcSpan -> Bool
`isSubspanOf` RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
current_toplevel_decl) SingleStep
GHC.SingleStep

stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd :: String -> m ()
stepModuleCmd String
arg = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":stepmodule" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
step String
arg
  where
  step :: String -> m ()
step String
expr
   | Bool -> Bool
not (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
expr) = String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepCmd String
expr
   | Bool
otherwise = do
      Maybe SrcSpan
mb_span <- m (Maybe SrcSpan)
forall (m :: Type -> Type). GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan
      case Maybe SrcSpan
mb_span of
        Maybe SrcSpan
Nothing  -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
stepCmd []
        Just SrcSpan
pan -> do
           let f :: SrcSpan -> Bool
f SrcSpan
some_span = SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
pan Maybe FastString -> Maybe FastString -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
some_span
           (SrcSpan -> Bool) -> SingleStep -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue SrcSpan -> Bool
f SingleStep
GHC.SingleStep

-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
enclosingTickSpan :: Module -> SrcSpan -> m RealSrcSpan
enclosingTickSpan Module
_ (UnhelpfulSpan FastString
_) = String -> m RealSrcSpan
forall a. String -> a
panic String
"enclosingTickSpan UnhelpfulSpan"
enclosingTickSpan Module
md (RealSrcSpan RealSrcSpan
src) = do
  TickArray
ticks <- Module -> m TickArray
forall (m :: Type -> Type). GhciMonad m => Module -> m TickArray
getTickArray Module
md
  let line :: Int
line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
src
  ASSERT(inRange (bounds ticks) line) do
  let enclosing_spans = [ pan | (_,pan) <- ticks ! line
                               , realSrcSpanEnd pan >= realSrcSpanEnd src]
  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
 where

leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan RealSrcSpan
a RealSrcSpan
b =
  (RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
a RealSrcLoc -> RealSrcLoc -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
b)
     Ordering -> Ordering -> Ordering
`thenCmp`
  (RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
b RealSrcLoc -> RealSrcLoc -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
a)

traceCmd :: GhciMonad m => String -> m ()
traceCmd :: String -> m ()
traceCmd String
arg
  = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":trace" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
tr String
arg
  where
  tr :: String -> m ()
tr []         = (SrcSpan -> Bool) -> SingleStep -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) SingleStep
GHC.RunAndLogSteps
  tr String
expression = String -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
String -> SingleStep -> m (Maybe ExecResult)
runStmt String
expression SingleStep
GHC.RunAndLogSteps m (Maybe ExecResult) -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

continueCmd :: GhciMonad m => String -> m ()
continueCmd :: String -> m ()
continueCmd = m () -> String -> m ()
forall (m :: Type -> Type). MonadIO m => m () -> String -> m ()
noArgs (m () -> String -> m ()) -> m () -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":continue" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> Bool) -> SingleStep -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) SingleStep
GHC.RunToCompletion

doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
doContinue :: (SrcSpan -> Bool) -> SingleStep -> m ()
doContinue SrcSpan -> Bool
pre SingleStep
step = do
  ExecResult
runResult <- (SrcSpan -> Bool) -> SingleStep -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ExecResult
resume SrcSpan -> Bool
pre SingleStep
step
  ExecResult
_ <- (SrcSpan -> Bool) -> ExecResult -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> ExecResult -> m ExecResult
afterRunStmt SrcSpan -> Bool
pre ExecResult
runResult
  () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

abandonCmd :: GhciMonad m => String -> m ()
abandonCmd :: String -> m ()
abandonCmd = m () -> String -> m ()
forall (m :: Type -> Type). MonadIO m => m () -> String -> m ()
noArgs (m () -> String -> m ()) -> m () -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":abandon" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
b <- m Bool
forall (m :: Type -> Type). GhcMonad m => m Bool
GHC.abandon -- the prompt will change to indicate the new context
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"There is no computation running."

deleteCmd :: GhciMonad m => String -> m ()
deleteCmd :: String -> m ()
deleteCmd String
argLine = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":delete" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
   [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
deleteSwitch ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
argLine
   where
   deleteSwitch :: GhciMonad m => [String] -> m ()
   deleteSwitch :: [String] -> m ()
deleteSwitch [] =
      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"The delete command requires at least one argument."
   -- delete all break points
   deleteSwitch (String
"*":[String]
_rest) = m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardActiveBreakPoints
   deleteSwitch [String]
idents = do
      (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m ()
forall (m :: Type -> Type). GhciMonad m => String -> m ()
deleteOneBreak [String]
idents
      where
      deleteOneBreak :: GhciMonad m => String -> m ()
      deleteOneBreak :: String -> m ()
deleteOneBreak String
str
         | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
str = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
deleteBreak (String -> Int
forall a. Read a => String -> a
read String
str)
         | Bool
otherwise = () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

enableCmd :: GhciMonad m => String -> m ()
enableCmd :: String -> m ()
enableCmd String
argLine = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":enable" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [String] -> m ()
enaDisaSwitch Bool
True ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
argLine

disableCmd :: GhciMonad m => String -> m ()
disableCmd :: String -> m ()
disableCmd String
argLine = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":disable" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [String] -> m ()
enaDisaSwitch Bool
False ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
argLine

enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()
enaDisaSwitch :: Bool -> [String] -> m ()
enaDisaSwitch Bool
enaDisa [] =
    MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (String -> MsgDoc
text String
"The" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
strCmd MsgDoc -> MsgDoc -> MsgDoc
<+>
                  String -> MsgDoc
text String
"command requires at least one argument.")
  where
    strCmd :: String
strCmd = if Bool
enaDisa then String
":enable" else String
":disable"
enaDisaSwitch Bool
enaDisa (String
"*" : [String]
_) = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
enaDisaAllBreaks Bool
enaDisa
enaDisaSwitch Bool
enaDisa [String]
idents = do
    (String -> m ()) -> [String] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> String -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> String -> m ()
enaDisaOneBreak Bool
enaDisa) [String]
idents
  where
    enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()
    enaDisaOneBreak :: Bool -> String -> m ()
enaDisaOneBreak Bool
enaDisa String
strId = do
      Either MsgDoc BreakLocation
sdoc_loc <- Bool -> String -> m (Either MsgDoc BreakLocation)
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> String -> m (Either MsgDoc BreakLocation)
getBreakLoc Bool
enaDisa String
strId
      case Either MsgDoc BreakLocation
sdoc_loc of
        Left MsgDoc
sdoc -> MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser MsgDoc
sdoc
        Right BreakLocation
loc -> Bool -> (Int, BreakLocation) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> (Int, BreakLocation) -> m ()
enaDisaAssoc Bool
enaDisa (String -> Int
forall a. Read a => String -> a
read String
strId, BreakLocation
loc)

getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)
getBreakLoc :: Bool -> String -> m (Either MsgDoc BreakLocation)
getBreakLoc Bool
enaDisa String
strId = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
strId Maybe Int -> (Int -> Maybe BreakLocation) -> Maybe BreakLocation
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> IntMap BreakLocation -> Maybe BreakLocation)
-> IntMap BreakLocation -> Int -> Maybe BreakLocation
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> IntMap BreakLocation -> Maybe BreakLocation
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (GHCiState -> IntMap BreakLocation
breaks GHCiState
st) of
      Maybe BreakLocation
Nothing -> Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation))
-> Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Either MsgDoc BreakLocation
forall a b. a -> Either a b
Left (String -> MsgDoc
text String
"Breakpoint" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
strId MsgDoc -> MsgDoc -> MsgDoc
<+>
                                String -> MsgDoc
text String
"not found")
      Just BreakLocation
loc ->
        if BreakLocation -> Bool
breakEnabled BreakLocation
loc Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
enaDisa
           then Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation))
-> Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Either MsgDoc BreakLocation
forall a b. a -> Either a b
Left
               (String -> MsgDoc
text String
"Breakpoint" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
strId MsgDoc -> MsgDoc -> MsgDoc
<+>
                String -> MsgDoc
text String
"already in desired state")
           else Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation))
-> Either MsgDoc BreakLocation -> m (Either MsgDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ BreakLocation -> Either MsgDoc BreakLocation
forall a b. b -> Either a b
Right BreakLocation
loc

enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()
enaDisaAssoc :: Bool -> (Int, BreakLocation) -> m ()
enaDisaAssoc Bool
enaDisa (Int
intId, BreakLocation
loc) = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    BreakLocation
newLoc <- Bool -> BreakLocation -> m BreakLocation
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff Bool
enaDisa BreakLocation
loc
    let new_breaks :: IntMap BreakLocation
new_breaks = Int
-> BreakLocation -> IntMap BreakLocation -> IntMap BreakLocation
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
intId BreakLocation
newLoc (GHCiState -> IntMap BreakLocation
breaks GHCiState
st)
    GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState (GHCiState -> m ()) -> GHCiState -> m ()
forall a b. (a -> b) -> a -> b
$ GHCiState
st { breaks :: IntMap BreakLocation
breaks = IntMap BreakLocation
new_breaks }

enaDisaAllBreaks :: GhciMonad m => Bool -> m()
enaDisaAllBreaks :: Bool -> m ()
enaDisaAllBreaks Bool
enaDisa = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    ((Int, BreakLocation) -> m ()) -> [(Int, BreakLocation)] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> (Int, BreakLocation) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> (Int, BreakLocation) -> m ()
enaDisaAssoc Bool
enaDisa) ([(Int, BreakLocation)] -> m ()) -> [(Int, BreakLocation)] -> m ()
forall a b. (a -> b) -> a -> b
$ IntMap BreakLocation -> [(Int, BreakLocation)]
forall a. IntMap a -> [(Int, a)]
IntMap.assocs (IntMap BreakLocation -> [(Int, BreakLocation)])
-> IntMap BreakLocation -> [(Int, BreakLocation)]
forall a b. (a -> b) -> a -> b
$ GHCiState -> IntMap BreakLocation
breaks GHCiState
st

historyCmd :: GHC.GhcMonad m => String -> m ()
historyCmd :: String -> m ()
historyCmd String
arg
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
arg        = Int -> m ()
forall (m :: Type -> Type). GhcMonad m => Int -> m ()
history Int
20
  | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg = Int -> m ()
forall (m :: Type -> Type). GhcMonad m => Int -> m ()
history (String -> Int
forall a. Read a => String -> a
read String
arg)
  | Bool
otherwise       = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Syntax:  :history [num]"
  where
  history :: Int -> m ()
history Int
num = do
    [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
    case [Resume]
resumes of
      [] -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Not stopped at a breakpoint"
      (Resume
r:[Resume]
_) -> do
        let hist :: [History]
hist = Resume -> [History]
GHC.resumeHistory Resume
r
            ([History]
took,[History]
rest) = Int -> [History] -> ([History], [History])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
num [History]
hist
        case [History]
hist of
          [] -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                   String
"Empty history. Perhaps you forgot to use :trace?"
          [History]
_  -> do
                 [SrcSpan]
pans <- (History -> m SrcSpan) -> [History] -> m [SrcSpan]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM History -> m SrcSpan
forall (m :: Type -> Type). GhcMonad m => History -> m SrcSpan
GHC.getHistorySpan [History]
took
                 let nums :: [String]
nums  = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"-%-3d:") [(Int
1::Int)..]
                     names :: [[String]]
names = (History -> [String]) -> [History] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map History -> [String]
GHC.historyEnclosingDecls [History]
took
                 MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser ([MsgDoc] -> MsgDoc
vcat((MsgDoc -> MsgDoc -> MsgDoc -> MsgDoc)
-> [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> [MsgDoc]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
                                 (\MsgDoc
x MsgDoc
y MsgDoc
z -> MsgDoc
x MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
y MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
z)
                                 ((String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text [String]
nums)
                                 (([String] -> MsgDoc) -> [[String]] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (MsgDoc -> MsgDoc
bold (MsgDoc -> MsgDoc) -> ([String] -> MsgDoc) -> [String] -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgDoc] -> MsgDoc
hcat ([MsgDoc] -> MsgDoc)
-> ([String] -> [MsgDoc]) -> [String] -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
colon ([MsgDoc] -> [MsgDoc])
-> ([String] -> [MsgDoc]) -> [String] -> [MsgDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text) [[String]]
names)
                                 ((SrcSpan -> MsgDoc) -> [SrcSpan] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (MsgDoc -> MsgDoc
parens (MsgDoc -> MsgDoc) -> (SrcSpan -> MsgDoc) -> SrcSpan -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr) [SrcSpan]
pans)))
                 IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ if [History] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [History]
rest then String
"<end of history>" else String
"..."

bold :: SDoc -> SDoc
bold :: MsgDoc -> MsgDoc
bold MsgDoc
c | Bool
do_bold   = String -> MsgDoc
text String
start_bold MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
c MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
end_bold
       | Bool
otherwise = MsgDoc
c

backCmd :: GhciMonad m => String -> m ()
backCmd :: String -> m ()
backCmd String
arg
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
arg        = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
back Int
1
  | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
back (String -> Int
forall a. Read a => String -> a
read String
arg)
  | Bool
otherwise       = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Syntax:  :back [num]"
  where
  back :: Int -> m ()
back Int
num = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":back" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ([Name]
names, Int
_, SrcSpan
pan, String
_) <- Int -> m ([Name], Int, SrcSpan, String)
forall (m :: Type -> Type).
GhcMonad m =>
Int -> m ([Name], Int, SrcSpan, String)
GHC.back Int
num
      MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"Logged breakpoint at") MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
pan
      [Name] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Name] -> m ()
printTypeOfNames [Name]
names
       -- run the command set with ":set stop <cmd>"
      GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [GHCiState -> String
stop GHCiState
st]

forwardCmd :: GhciMonad m => String -> m ()
forwardCmd :: String -> m ()
forwardCmd String
arg
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
arg        = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
forward Int
1
  | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
forward (String -> Int
forall a. Read a => String -> a
read String
arg)
  | Bool
otherwise       = IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Syntax:  :forward [num]"
  where
  forward :: Int -> m ()
forward Int
num = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":forward" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ([Name]
names, Int
ix, SrcSpan
pan, String
_) <- Int -> m ([Name], Int, SrcSpan, String)
forall (m :: Type -> Type).
GhcMonad m =>
Int -> m ([Name], Int, SrcSpan, String)
GHC.forward Int
num
      MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ (if (Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
                        then PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"Stopped at")
                        else PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"Logged breakpoint at")) MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
pan
      [Name] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Name] -> m ()
printTypeOfNames [Name]
names
       -- run the command set with ":set stop <cmd>"
      GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
enqueueCommands [GHCiState -> String
stop GHCiState
st]

-- handle the "break" command
breakCmd :: GhciMonad m => String -> m ()
breakCmd :: String -> m ()
breakCmd String
argLine = String -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => String -> m () -> m ()
withSandboxOnly String
":break" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
breakSwitch ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
argLine

breakSwitch :: GhciMonad m => [String] -> m ()
breakSwitch :: [String] -> m ()
breakSwitch [] = do
   IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"The break command requires at least one argument."
breakSwitch (String
arg1:[String]
rest)
   | String -> Bool
looksLikeModuleName String
arg1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
rest) = do
        Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
wantInterpretedModule String
arg1
        Module -> [String] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> [String] -> m ()
breakByModule Module
md [String]
rest
   | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg1 = do
        [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
        case [InteractiveImport] -> [ModuleName]
iiModules [InteractiveImport]
imports of
           (ModuleName
mn : [ModuleName]
_) -> do
              Module
md <- ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
lookupModuleName ModuleName
mn
              Module -> Int -> [String] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> Int -> [String] -> m ()
breakByModuleLine Module
md (String -> Int
forall a. Read a => String -> a
read String
arg1) [String]
rest
           [] -> do
              IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No modules are loaded with debugging support."
   | Bool
otherwise = do -- try parsing it as an identifier
        (Name -> MsgDoc -> m ()) -> String -> (Name -> m ()) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(Name -> MsgDoc -> m ()) -> String -> (Name -> m ()) -> m ()
wantNameFromInterpretedModule Name -> MsgDoc -> m ()
forall (m :: Type -> Type) a.
(GhcMonad m, Outputable a) =>
a -> MsgDoc -> m ()
noCanDo String
arg1 ((Name -> m ()) -> m ()) -> (Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
        Maybe ModuleInfo
maybe_info <- Module -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo (HasDebugCallStack => Name -> Module
Name -> Module
GHC.nameModule Name
name)
        case Maybe ModuleInfo
maybe_info of
          Maybe ModuleInfo
Nothing -> Name -> MsgDoc -> m ()
forall (m :: Type -> Type) a.
(GhcMonad m, Outputable a) =>
a -> MsgDoc -> m ()
noCanDo Name
name (PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"cannot get module info"))
          Just ModuleInfo
minf ->
               ASSERT( isExternalName name )
                    Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet (HasDebugCallStack => Name -> Module
Name -> Module
GHC.nameModule Name
name) ((TickArray -> [(Int, RealSrcSpan)]) -> m ())
-> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall a b. (a -> b) -> a -> b
$
                       Name -> ModBreaks -> TickArray -> [(Int, RealSrcSpan)]
findBreakForBind Name
name (ModuleInfo -> ModBreaks
GHC.modInfoModBreaks ModuleInfo
minf)
       where
          noCanDo :: a -> MsgDoc -> m ()
noCanDo a
n MsgDoc
why = MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> MsgDoc
text String
"cannot set breakpoint on " MsgDoc -> MsgDoc -> MsgDoc
<> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
n MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
": " MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
why

breakByModule :: GhciMonad m => Module -> [String] -> m ()
breakByModule :: Module -> [String] -> m ()
breakByModule Module
md (String
arg1:[String]
rest)
   | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg1 = do  -- looks like a line number
        Module -> Int -> [String] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> Int -> [String] -> m ()
breakByModuleLine Module
md (String -> Int
forall a. Read a => String -> a
read String
arg1) [String]
rest
breakByModule Module
_ [String]
_
   = m ()
forall a. a
breakSyntax

breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
breakByModuleLine :: Module -> Int -> [String] -> m ()
breakByModuleLine Module
md Int
line [String]
args
   | [] <- [String]
args = Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet Module
md ((TickArray -> [(Int, RealSrcSpan)]) -> m ())
-> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Int, RealSrcSpan) -> [(Int, RealSrcSpan)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Int, RealSrcSpan) -> [(Int, RealSrcSpan)])
-> (TickArray -> Maybe (Int, RealSrcSpan))
-> TickArray
-> [(Int, RealSrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TickArray -> Maybe (Int, RealSrcSpan)
findBreakByLine Int
line
   | [String
col] <- [String]
args, (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
col =
        Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet Module
md ((TickArray -> [(Int, RealSrcSpan)]) -> m ())
-> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Int, RealSrcSpan) -> [(Int, RealSrcSpan)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Int, RealSrcSpan) -> [(Int, RealSrcSpan)])
-> (TickArray -> Maybe (Int, RealSrcSpan))
-> TickArray
-> [(Int, RealSrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FastString
-> (Int, Int) -> TickArray -> Maybe (Int, RealSrcSpan)
findBreakByCoord Maybe FastString
forall a. Maybe a
Nothing (Int
line, String -> Int
forall a. Read a => String -> a
read String
col)
   | Bool
otherwise = m ()
forall a. a
breakSyntax

breakSyntax :: a
breakSyntax :: a
breakSyntax = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"Syntax: :break [<mod>] <line> [<column>]")

findBreakAndSet :: GhciMonad m
                => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet Module
md TickArray -> [(Int, RealSrcSpan)]
lookupTickTree = do
   TickArray
tickArray <- Module -> m TickArray
forall (m :: Type -> Type). GhciMonad m => Module -> m TickArray
getTickArray Module
md
   (ForeignRef BreakArray
breakArray, Array Int SrcSpan
_) <- Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak Module
md
   case TickArray -> [(Int, RealSrcSpan)]
lookupTickTree TickArray
tickArray of
      []  -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No breakpoints found at that location."
      [(Int, RealSrcSpan)]
some -> ((Int, RealSrcSpan) -> m ()) -> [(Int, RealSrcSpan)] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ForeignRef BreakArray -> (Int, RealSrcSpan) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
ForeignRef BreakArray -> (Int, RealSrcSpan) -> m ()
breakAt ForeignRef BreakArray
breakArray) [(Int, RealSrcSpan)]
some
 where
   breakAt :: ForeignRef BreakArray -> (Int, RealSrcSpan) -> m ()
breakAt ForeignRef BreakArray
breakArray (Int
tick, RealSrcSpan
pan) = do
         Bool -> ForeignRef BreakArray -> Int -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> ForeignRef BreakArray -> Int -> m ()
setBreakFlag Bool
True ForeignRef BreakArray
breakArray Int
tick
         (Bool
alreadySet, Int
nm) <-
               BreakLocation -> m (Bool, Int)
forall (m :: Type -> Type).
GhciMonad m =>
BreakLocation -> m (Bool, Int)
recordBreak (BreakLocation -> m (Bool, Int)) -> BreakLocation -> m (Bool, Int)
forall a b. (a -> b) -> a -> b
$ BreakLocation :: Module -> SrcSpan -> Int -> Bool -> String -> BreakLocation
BreakLocation
                       { breakModule :: Module
breakModule = Module
md
                       , breakLoc :: SrcSpan
breakLoc = RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
pan
                       , breakTick :: Int
breakTick = Int
tick
                       , onBreakCmd :: String
onBreakCmd = String
""
                       , breakEnabled :: Bool
breakEnabled = Bool
True
                       }
         MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> MsgDoc
text String
"Breakpoint " MsgDoc -> MsgDoc -> MsgDoc
<> Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int
nm MsgDoc -> MsgDoc -> MsgDoc
<>
            if Bool
alreadySet
               then String -> MsgDoc
text String
" was already set at " MsgDoc -> MsgDoc -> MsgDoc
<> RealSrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RealSrcSpan
pan
               else String -> MsgDoc
text String
" activated at " MsgDoc -> MsgDoc -> MsgDoc
<> RealSrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RealSrcSpan
pan

-- When a line number is specified, the current policy for choosing
-- the best breakpoint is this:
--    - the leftmost complete subexpression on the specified line, or
--    - the leftmost subexpression starting on the specified line, or
--    - the rightmost subexpression enclosing the specified line
--
findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
findBreakByLine :: Int -> TickArray -> Maybe (Int, RealSrcSpan)
findBreakByLine Int
line TickArray
arr
  | Bool -> Bool
not ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (TickArray -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds TickArray
arr) Int
line) = Maybe (Int, RealSrcSpan)
forall a. Maybe a
Nothing
  | Bool
otherwise =
    [(Int, RealSrcSpan)] -> Maybe (Int, RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe (((Int, RealSrcSpan) -> (Int, RealSrcSpan) -> Ordering)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan (RealSrcSpan -> RealSrcSpan -> Ordering)
-> ((Int, RealSrcSpan) -> RealSrcSpan)
-> (Int, RealSrcSpan)
-> (Int, RealSrcSpan)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, RealSrcSpan) -> RealSrcSpan
forall a b. (a, b) -> b
snd)  [(Int, RealSrcSpan)]
comp)   Maybe (Int, RealSrcSpan)
-> Maybe (Int, RealSrcSpan) -> Maybe (Int, RealSrcSpan)
forall (m :: Type -> Type) a. MonadPlus m => m a -> m a -> m a
`mplus`
    [(Int, RealSrcSpan)] -> Maybe (Int, RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe (((Int, RealSrcSpan) -> (Int, RealSrcSpan) -> Ordering)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> ((Int, RealSrcSpan) -> RealSrcSpan)
-> (Int, RealSrcSpan)
-> (Int, RealSrcSpan)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, RealSrcSpan) -> RealSrcSpan
forall a b. (a, b) -> b
snd) [(Int, RealSrcSpan)]
incomp) Maybe (Int, RealSrcSpan)
-> Maybe (Int, RealSrcSpan) -> Maybe (Int, RealSrcSpan)
forall (m :: Type -> Type) a. MonadPlus m => m a -> m a -> m a
`mplus`
    [(Int, RealSrcSpan)] -> Maybe (Int, RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe (((Int, RealSrcSpan) -> (Int, RealSrcSpan) -> Ordering)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((RealSrcSpan -> RealSrcSpan -> Ordering)
-> RealSrcSpan -> RealSrcSpan -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> ((Int, RealSrcSpan) -> RealSrcSpan)
-> (Int, RealSrcSpan)
-> (Int, RealSrcSpan)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, RealSrcSpan) -> RealSrcSpan
forall a b. (a, b) -> b
snd) [(Int, RealSrcSpan)]
ticks)
  where
        ticks :: [(Int, RealSrcSpan)]
ticks = TickArray
arr TickArray -> Int -> [(Int, RealSrcSpan)]
forall i e. Ix i => Array i e -> i -> e
! Int
line

        starts_here :: [(Int, RealSrcSpan)]
starts_here = [ (Int
ix,RealSrcSpan
pan) | (Int
ix, RealSrcSpan
pan) <- [(Int, RealSrcSpan)]
ticks,
                        RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
pan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line ]

        ([(Int, RealSrcSpan)]
comp, [(Int, RealSrcSpan)]
incomp) = ((Int, RealSrcSpan) -> Bool)
-> [(Int, RealSrcSpan)]
-> ([(Int, RealSrcSpan)], [(Int, RealSrcSpan)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Int, RealSrcSpan) -> Bool
forall a. (a, RealSrcSpan) -> Bool
ends_here [(Int, RealSrcSpan)]
starts_here
            where ends_here :: (a, RealSrcSpan) -> Bool
ends_here (a
_,RealSrcSpan
pan) = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
pan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line

-- The aim is to find the breakpoints for all the RHSs of the
-- equations corresponding to a binding.  So we find all breakpoints
-- for
--   (a) this binder only (not a nested declaration)
--   (b) that do not have an enclosing breakpoint
findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
                 -> [(BreakIndex,RealSrcSpan)]
findBreakForBind :: Name -> ModBreaks -> TickArray -> [(Int, RealSrcSpan)]
findBreakForBind Name
name ModBreaks
modbreaks TickArray
_ = ((Int, RealSrcSpan) -> Bool)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Int, RealSrcSpan) -> Bool) -> (Int, RealSrcSpan) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, RealSrcSpan) -> Bool
forall a. (a, RealSrcSpan) -> Bool
enclosed) [(Int, RealSrcSpan)]
ticks
  where
    ticks :: [(Int, RealSrcSpan)]
ticks = [ (Int
index, RealSrcSpan
span)
            | (Int
index, [String
n]) <- Array Int [String] -> [(Int, [String])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (ModBreaks -> Array Int [String]
GHC.modBreaks_decls ModBreaks
modbreaks),
              String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== OccName -> String
occNameString (Name -> OccName
nameOccName Name
name),
              RealSrcSpan RealSrcSpan
span <- [ModBreaks -> Array Int SrcSpan
GHC.modBreaks_locs ModBreaks
modbreaks Array Int SrcSpan -> Int -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! Int
index] ]
    enclosed :: (a, RealSrcSpan) -> Bool
enclosed (a
_,RealSrcSpan
sp0) = ((Int, RealSrcSpan) -> Bool) -> [(Int, RealSrcSpan)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Int, RealSrcSpan) -> Bool
forall a. (a, RealSrcSpan) -> Bool
subspan [(Int, RealSrcSpan)]
ticks
      where subspan :: (a, RealSrcSpan) -> Bool
subspan (a
_,RealSrcSpan
sp) = RealSrcSpan
sp RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan
sp0 Bool -> Bool -> Bool
&&
                         RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
sp RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
sp0 Bool -> Bool -> Bool
&&
                         RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
sp0 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
sp

findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
                 -> Maybe (BreakIndex,RealSrcSpan)
findBreakByCoord :: Maybe FastString
-> (Int, Int) -> TickArray -> Maybe (Int, RealSrcSpan)
findBreakByCoord Maybe FastString
mb_file (Int
line, Int
col) TickArray
arr
  | Bool -> Bool
not ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (TickArray -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds TickArray
arr) Int
line) = Maybe (Int, RealSrcSpan)
forall a. Maybe a
Nothing
  | Bool
otherwise =
    [(Int, RealSrcSpan)] -> Maybe (Int, RealSrcSpan)
forall a. [a] -> Maybe a
listToMaybe (((Int, RealSrcSpan) -> (Int, RealSrcSpan) -> Ordering)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((RealSrcSpan -> RealSrcSpan -> Ordering)
-> RealSrcSpan -> RealSrcSpan -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> ((Int, RealSrcSpan) -> RealSrcSpan)
-> (Int, RealSrcSpan)
-> (Int, RealSrcSpan)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, RealSrcSpan) -> RealSrcSpan
forall a b. (a, b) -> b
snd) [(Int, RealSrcSpan)]
contains [(Int, RealSrcSpan)]
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. [a] -> [a] -> [a]
++
                 ((Int, RealSrcSpan) -> (Int, RealSrcSpan) -> Ordering)
-> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> ((Int, RealSrcSpan) -> RealSrcSpan)
-> (Int, RealSrcSpan)
-> (Int, RealSrcSpan)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, RealSrcSpan) -> RealSrcSpan
forall a b. (a, b) -> b
snd) [(Int, RealSrcSpan)]
after_here)
  where
        ticks :: [(Int, RealSrcSpan)]
ticks = TickArray
arr TickArray -> Int -> [(Int, RealSrcSpan)]
forall i e. Ix i => Array i e -> i -> e
! Int
line

        -- the ticks that span this coordinate
        contains :: [(Int, RealSrcSpan)]
contains = [ (Int, RealSrcSpan)
tick | tick :: (Int, RealSrcSpan)
tick@(Int
_,RealSrcSpan
pan) <- [(Int, RealSrcSpan)]
ticks, RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
pan SrcSpan -> (Int, Int) -> Bool
`spans` (Int
line,Int
col),
                            RealSrcSpan -> Bool
is_correct_file RealSrcSpan
pan ]

        is_correct_file :: RealSrcSpan -> Bool
is_correct_file RealSrcSpan
pan
                 | Just FastString
f <- Maybe FastString
mb_file = RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
pan FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
f
                 | Bool
otherwise         = Bool
True

        after_here :: [(Int, RealSrcSpan)]
after_here = [ (Int, RealSrcSpan)
tick | tick :: (Int, RealSrcSpan)
tick@(Int
_,RealSrcSpan
pan) <- [(Int, RealSrcSpan)]
ticks,
                              RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
pan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line,
                              RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
pan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
col ]

-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
-- In particular, on Windows and when running the testsuite (which sets
-- TERM to vt100 for other reasons) we get carets.
-- We really ought to use a proper termcap/terminfo library.
do_bold :: Bool
do_bold :: Bool
do_bold = (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` IO String -> String
forall a. IO a -> a
unsafePerformIO IO String
mTerm) (String -> Bool) -> [String] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
`any` [String
"xterm", String
"linux"]
    where mTerm :: IO String
mTerm = String -> IO String
System.Environment.getEnv String
"TERM"
                  IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
"TERM not set"

start_bold :: String
start_bold :: String
start_bold = String
"\ESC[1m"
end_bold :: String
end_bold :: String
end_bold   = String
"\ESC[0m"

-----------------------------------------------------------------------------
-- :where

whereCmd :: GHC.GhcMonad m => String -> m ()
whereCmd :: String -> m ()
whereCmd = m () -> String -> m ()
forall (m :: Type -> Type). MonadIO m => m () -> String -> m ()
noArgs (m () -> String -> m ()) -> m () -> String -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Maybe [String]
mstrs <- m (Maybe [String])
forall (m :: Type -> Type). GhcMonad m => m (Maybe [String])
getCallStackAtCurrentBreakpoint
  case Maybe [String]
mstrs of
    Maybe [String]
Nothing -> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
    Just [String]
strs -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ([String] -> String
renderStack [String]
strs)

-----------------------------------------------------------------------------
-- :list

listCmd :: GhciMonad m => String -> m ()
listCmd :: String -> m ()
listCmd String
"" = do
   Maybe SrcSpan
mb_span <- m (Maybe SrcSpan)
forall (m :: Type -> Type). GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan
   case Maybe SrcSpan
mb_span of
      Maybe SrcSpan
Nothing ->
          MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"Not stopped at a breakpoint; nothing to list"
      Just (RealSrcSpan RealSrcSpan
pan) ->
          RealSrcSpan -> Bool -> m ()
forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround RealSrcSpan
pan Bool
True
      Just pan :: SrcSpan
pan@(UnhelpfulSpan FastString
_) ->
          do [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
             case [Resume]
resumes of
                 [] -> String -> m ()
forall a. String -> a
panic String
"No resumes"
                 (Resume
r:[Resume]
_) ->
                     do let traceIt :: MsgDoc
traceIt = case Resume -> [History]
GHC.resumeHistory Resume
r of
                                      [] -> String -> MsgDoc
text String
"rerunning with :trace,"
                                      [History]
_ -> MsgDoc
empty
                            doWhat :: MsgDoc
doWhat = MsgDoc
traceIt MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
":back then :list"
                        MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (String -> MsgDoc
text String
"Unable to list source for" MsgDoc -> MsgDoc -> MsgDoc
<+>
                                      SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
pan
                                   MsgDoc -> MsgDoc -> MsgDoc
$$ String -> MsgDoc
text String
"Try" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doWhat)
listCmd String
str = [String] -> m ()
forall (m :: Type -> Type). GhciMonad m => [String] -> m ()
list2 (String -> [String]
words String
str)

list2 :: GhciMonad m => [String] -> m ()
list2 :: [String] -> m ()
list2 [String
arg] | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg = do
    [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
    case [InteractiveImport] -> [ModuleName]
iiModules [InteractiveImport]
imports of
        [] -> IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No module to list"
        (ModuleName
mn : [ModuleName]
_) -> do
          Module
md <- ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
lookupModuleName ModuleName
mn
          Module -> Int -> m ()
forall (m :: Type -> Type). GhcMonad m => Module -> Int -> m ()
listModuleLine Module
md (String -> Int
forall a. Read a => String -> a
read String
arg)
list2 [String
arg1,String
arg2] | String -> Bool
looksLikeModuleName String
arg1, (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg2 = do
        Module
md <- String -> m Module
forall (m :: Type -> Type). GhcMonad m => String -> m Module
wantInterpretedModule String
arg1
        Module -> Int -> m ()
forall (m :: Type -> Type). GhcMonad m => Module -> Int -> m ()
listModuleLine Module
md (String -> Int
forall a. Read a => String -> a
read String
arg2)
list2 [String
arg] = do
        (Name -> MsgDoc -> m ()) -> String -> (Name -> m ()) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(Name -> MsgDoc -> m ()) -> String -> (Name -> m ()) -> m ()
wantNameFromInterpretedModule Name -> MsgDoc -> m ()
forall (m :: Type -> Type) a.
(GhcMonad m, Outputable a) =>
a -> MsgDoc -> m ()
noCanDo String
arg ((Name -> m ()) -> m ()) -> (Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
        let loc :: SrcLoc
loc = SrcSpan -> SrcLoc
GHC.srcSpanStart (Name -> SrcSpan
GHC.nameSrcSpan Name
name)
        case SrcLoc
loc of
            RealSrcLoc RealSrcLoc
l ->
               do TickArray
tickArray <- ASSERT( isExternalName name )
                               Module -> m TickArray
forall (m :: Type -> Type). GhciMonad m => Module -> m TickArray
getTickArray (HasDebugCallStack => Name -> Module
Name -> Module
GHC.nameModule Name
name)
                  let mb_span :: Maybe (Int, RealSrcSpan)
mb_span = Maybe FastString
-> (Int, Int) -> TickArray -> Maybe (Int, RealSrcSpan)
findBreakByCoord (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (RealSrcLoc -> FastString
GHC.srcLocFile RealSrcLoc
l))
                                        (RealSrcLoc -> Int
GHC.srcLocLine RealSrcLoc
l, RealSrcLoc -> Int
GHC.srcLocCol RealSrcLoc
l)
                                        TickArray
tickArray
                  case Maybe (Int, RealSrcSpan)
mb_span of
                    Maybe (Int, RealSrcSpan)
Nothing       -> RealSrcSpan -> Bool -> m ()
forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround (RealSrcLoc -> RealSrcSpan
realSrcLocSpan RealSrcLoc
l) Bool
False
                    Just (Int
_, RealSrcSpan
pan) -> RealSrcSpan -> Bool -> m ()
forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround RealSrcSpan
pan Bool
False
            UnhelpfulLoc FastString
_ ->
                  Name -> MsgDoc -> m ()
forall (m :: Type -> Type) a.
(GhcMonad m, Outputable a) =>
a -> MsgDoc -> m ()
noCanDo Name
name (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"can't find its location: " MsgDoc -> MsgDoc -> MsgDoc
<>
                                 SrcLoc -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcLoc
loc
    where
        noCanDo :: a -> MsgDoc -> m ()
noCanDo a
n MsgDoc
why = MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> MsgDoc
text String
"cannot list source code for " MsgDoc -> MsgDoc -> MsgDoc
<> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
n MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
": " MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
why
list2  [String]
_other =
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"syntax:  :list [<line> | <module> <line> | <identifier>]"

listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()
listModuleLine :: Module -> Int -> m ()
listModuleLine Module
modl Int
line = do
   ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
   let this :: Maybe ModSummary
this = ModuleGraph -> Module -> Maybe ModSummary
GHC.mgLookupModule ModuleGraph
graph Module
modl
   case Maybe ModSummary
this of
     Maybe ModSummary
Nothing -> String -> m ()
forall a. String -> a
panic String
"listModuleLine"
     Just ModSummary
summ -> do
           let filename :: String
filename = String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"listModuleLine" (ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
summ))
               loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString (String
filename)) Int
line Int
0
           RealSrcSpan -> Bool -> m ()
forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround (RealSrcLoc -> RealSrcSpan
realSrcLocSpan RealSrcLoc
loc) Bool
False

-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- start_bold\/end_bold.

-- GHC files are UTF-8, so we can implement this by:
-- 1) read the file in as a BS and syntax highlight it as before
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()
listAround :: RealSrcSpan -> Bool -> m ()
listAround RealSrcSpan
pan Bool
do_highlight = do
      ByteString
contents <- IO ByteString -> m ByteString
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile (FastString -> String
unpackFS FastString
file)
      -- Drop carriage returns to avoid duplicates, see #9367.
      let ls :: [ByteString]
ls  = Char -> ByteString -> [ByteString]
BS.split Char
'\n' (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') ByteString
contents
          ls' :: [ByteString]
ls' = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take (Int
line2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pad_before Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pad_after) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
                        Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop (Int
line1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pad_before) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
ls
          fst_line :: Int
fst_line = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
line1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pad_before)
          line_nos :: [Int]
line_nos = [ Int
fst_line .. ]

          highlighted :: [ByteString -> ByteString]
highlighted | Bool
do_highlight = (Int -> ByteString -> ByteString -> ByteString)
-> [Int] -> [ByteString] -> [ByteString -> ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ByteString -> ByteString -> ByteString
highlight [Int]
line_nos [ByteString]
ls'
                      | Bool
otherwise    = [\ByteString
p -> [ByteString] -> ByteString
BS.concat[ByteString
p,ByteString
l] | ByteString
l <- [ByteString]
ls']

          bs_line_nos :: [ByteString]
bs_line_nos = [ String -> ByteString
BS.pack (Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  ") | Int
l <- [Int]
line_nos ]
          prefixed :: [ByteString]
prefixed = ((ByteString -> ByteString) -> ByteString -> ByteString)
-> [ByteString -> ByteString] -> [ByteString] -> [ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
($) [ByteString -> ByteString]
highlighted [ByteString]
bs_line_nos
          output :: ByteString
output   = ByteString -> [ByteString] -> ByteString
BS.intercalate (String -> ByteString
BS.pack String
"\n") [ByteString]
prefixed

      let utf8Decoded :: String
utf8Decoded = ByteString -> String
utf8DecodeByteString ByteString
output
      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
utf8Decoded
  where
        file :: FastString
file  = RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
pan
        line1 :: Int
line1 = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
pan
        col1 :: Int
col1  = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
pan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        line2 :: Int
line2 = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
pan
        col2 :: Int
col2  = RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
pan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

        pad_before :: Int
pad_before | Int
line1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
0
                   | Bool
otherwise  = Int
1
        pad_after :: Int
pad_after = Int
1

        highlight :: Int -> ByteString -> ByteString -> ByteString
highlight | Bool
do_bold   = Int -> ByteString -> ByteString -> ByteString
highlight_bold
                  | Bool
otherwise = Int -> ByteString -> ByteString -> ByteString
highlight_carets

        highlight_bold :: Int -> ByteString -> ByteString -> ByteString
highlight_bold Int
no ByteString
line ByteString
prefix
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line1 Bool -> Bool -> Bool
&& Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line2
          = let (ByteString
a,ByteString
r) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
col1 ByteString
line
                (ByteString
b,ByteString
c) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
col2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
col1) ByteString
r
            in
            [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
a,String -> ByteString
BS.pack String
start_bold,ByteString
b,String -> ByteString
BS.pack String
end_bold,ByteString
c]
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line1
          = let (ByteString
a,ByteString
b) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
col1 ByteString
line in
            [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
a, String -> ByteString
BS.pack String
start_bold, ByteString
b]
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line2
          = let (ByteString
a,ByteString
b) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
col2 ByteString
line in
            [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
a, String -> ByteString
BS.pack String
end_bold, ByteString
b]
          | Bool
otherwise   = [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
line]

        highlight_carets :: Int -> ByteString -> ByteString -> ByteString
highlight_carets Int
no ByteString
line ByteString
prefix
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line1 Bool -> Bool -> Bool
&& Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line2
          = [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
line, ByteString
nl, ByteString
indent, Int -> Char -> ByteString
BS.replicate Int
col1 Char
' ',
                                         Int -> Char -> ByteString
BS.replicate (Int
col2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
col1) Char
'^']
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line1
          = [ByteString] -> ByteString
BS.concat [ByteString
indent, Int -> Char -> ByteString
BS.replicate (Int
col1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Char
' ', String -> ByteString
BS.pack String
"vv", ByteString
nl,
                                         ByteString
prefix, ByteString
line]
          | Int
no Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line2
          = [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
line, ByteString
nl, ByteString
indent, Int -> Char -> ByteString
BS.replicate Int
col2 Char
' ',
                                         String -> ByteString
BS.pack String
"^^"]
          | Bool
otherwise   = [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
line]
         where
           indent :: ByteString
indent = String -> ByteString
BS.pack (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
no)) Char
' ')
           nl :: ByteString
nl = Char -> ByteString
BS.singleton Char
'\n'


-- --------------------------------------------------------------------------
-- Tick arrays

getTickArray :: GhciMonad m => Module -> m TickArray
getTickArray :: Module -> m TickArray
getTickArray Module
modl = do
   GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
   let arrmap :: ModuleEnv TickArray
arrmap = GHCiState -> ModuleEnv TickArray
tickarrays GHCiState
st
   case ModuleEnv TickArray -> Module -> Maybe TickArray
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv TickArray
arrmap Module
modl of
      Just TickArray
arr -> TickArray -> m TickArray
forall (m :: Type -> Type) a. Monad m => a -> m a
return TickArray
arr
      Maybe TickArray
Nothing  -> do
        (ForeignRef BreakArray
_breakArray, Array Int SrcSpan
ticks) <- Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak Module
modl
        let arr :: TickArray
arr = [(Int, SrcSpan)] -> TickArray
mkTickArray (Array Int SrcSpan -> [(Int, SrcSpan)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int SrcSpan
ticks)
        GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{tickarrays :: ModuleEnv TickArray
tickarrays = ModuleEnv TickArray -> Module -> TickArray -> ModuleEnv TickArray
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv TickArray
arrmap Module
modl TickArray
arr}
        TickArray -> m TickArray
forall (m :: Type -> Type) a. Monad m => a -> m a
return TickArray
arr

discardTickArrays :: GhciMonad m => m ()
discardTickArrays :: m ()
discardTickArrays = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st {tickarrays :: ModuleEnv TickArray
tickarrays = ModuleEnv TickArray
forall a. ModuleEnv a
emptyModuleEnv})

mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
mkTickArray :: [(Int, SrcSpan)] -> TickArray
mkTickArray [(Int, SrcSpan)]
ticks
  = ([(Int, RealSrcSpan)]
 -> (Int, RealSrcSpan) -> [(Int, RealSrcSpan)])
-> [(Int, RealSrcSpan)]
-> (Int, Int)
-> [(Int, (Int, RealSrcSpan))]
-> TickArray
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (((Int, RealSrcSpan)
 -> [(Int, RealSrcSpan)] -> [(Int, RealSrcSpan)])
-> [(Int, RealSrcSpan)]
-> (Int, RealSrcSpan)
-> [(Int, RealSrcSpan)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] (Int
1, Int
max_line)
        [ (Int
line, (Int
nm,RealSrcSpan
pan)) | (Int
nm,RealSrcSpan RealSrcSpan
pan) <- [(Int, SrcSpan)]
ticks, Int
line <- RealSrcSpan -> [Int]
srcSpanLines RealSrcSpan
pan ]
    where
        max_line :: Int
max_line = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 [ RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
sp | (Int
_, RealSrcSpan RealSrcSpan
sp) <- [(Int, SrcSpan)]
ticks ]
        srcSpanLines :: RealSrcSpan -> [Int]
srcSpanLines RealSrcSpan
pan = [ RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
pan ..  RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
pan ]

-- don't reset the counter back to zero?
discardActiveBreakPoints :: GhciMonad m => m ()
discardActiveBreakPoints :: m ()
discardActiveBreakPoints = do
   GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
   (BreakLocation -> m BreakLocation) -> IntMap BreakLocation -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> BreakLocation -> m BreakLocation
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff Bool
False) (IntMap BreakLocation -> m ()) -> IntMap BreakLocation -> m ()
forall a b. (a -> b) -> a -> b
$ GHCiState -> IntMap BreakLocation
breaks GHCiState
st
   GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState (GHCiState -> m ()) -> GHCiState -> m ()
forall a b. (a -> b) -> a -> b
$ GHCiState
st { breaks :: IntMap BreakLocation
breaks = IntMap BreakLocation
forall a. IntMap a
IntMap.empty }

deleteBreak :: GhciMonad m => Int -> m ()
deleteBreak :: Int -> m ()
deleteBreak Int
identity = do
   GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
   let oldLocations :: IntMap BreakLocation
oldLocations = GHCiState -> IntMap BreakLocation
breaks GHCiState
st
   case Int -> IntMap BreakLocation -> Maybe BreakLocation
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
identity IntMap BreakLocation
oldLocations of
       Maybe BreakLocation
Nothing -> MsgDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => MsgDoc -> m ()
printForUser (String -> MsgDoc
text String
"Breakpoint" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int
identity MsgDoc -> MsgDoc -> MsgDoc
<+>
                                String -> MsgDoc
text String
"does not exist")
       Just BreakLocation
loc -> do
           BreakLocation
_ <- (Bool -> BreakLocation -> m BreakLocation
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff Bool
False) BreakLocation
loc
           let rest :: IntMap BreakLocation
rest = Int -> IntMap BreakLocation -> IntMap BreakLocation
forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
identity IntMap BreakLocation
oldLocations
           GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState (GHCiState -> m ()) -> GHCiState -> m ()
forall a b. (a -> b) -> a -> b
$ GHCiState
st { breaks :: IntMap BreakLocation
breaks = IntMap BreakLocation
rest }

turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff :: Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff Bool
onOff BreakLocation
loc
  | Bool
onOff Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== BreakLocation -> Bool
breakEnabled BreakLocation
loc = BreakLocation -> m BreakLocation
forall (m :: Type -> Type) a. Monad m => a -> m a
return BreakLocation
loc
  | Bool
otherwise = do
      (ForeignRef BreakArray
arr, Array Int SrcSpan
_) <- Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak (BreakLocation -> Module
breakModule BreakLocation
loc)
      HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
enableBreakpoint HscEnv
hsc_env ForeignRef BreakArray
arr (BreakLocation -> Int
breakTick BreakLocation
loc) Bool
onOff
      BreakLocation -> m BreakLocation
forall (m :: Type -> Type) a. Monad m => a -> m a
return BreakLocation
loc { breakEnabled :: Bool
breakEnabled = Bool
onOff }

getModBreak :: GHC.GhcMonad m
            => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak :: Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak Module
m = do
   ModuleInfo
mod_info      <- ModuleInfo -> Maybe ModuleInfo -> ModuleInfo
forall a. a -> Maybe a -> a
fromMaybe (String -> ModuleInfo
forall a. String -> a
panic String
"getModBreak") (Maybe ModuleInfo -> ModuleInfo)
-> m (Maybe ModuleInfo) -> m ModuleInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
m
   let modBreaks :: ModBreaks
modBreaks  = ModuleInfo -> ModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
   let arr :: ForeignRef BreakArray
arr        = ModBreaks -> ForeignRef BreakArray
GHC.modBreaks_flags ModBreaks
modBreaks
   let ticks :: Array Int SrcSpan
ticks      = ModBreaks -> Array Int SrcSpan
GHC.modBreaks_locs  ModBreaks
modBreaks
   (ForeignRef BreakArray, Array Int SrcSpan)
-> m (ForeignRef BreakArray, Array Int SrcSpan)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ForeignRef BreakArray
arr, Array Int SrcSpan
ticks)

setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()
setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> m ()
setBreakFlag Bool
toggle ForeignRef BreakArray
arr Int
i = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
enableBreakpoint HscEnv
hsc_env ForeignRef BreakArray
arr Int
i Bool
toggle

-- ---------------------------------------------------------------------------
-- User code exception handling

-- This is the exception handler for exceptions generated by the
-- user's code and exceptions coming from children sessions;
-- it normally just prints out the exception.  The
-- handler must be recursive, in case showing the exception causes
-- more exceptions to be raised.
--
-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
-- raising another exception.  We therefore don't put the recursive
-- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop.
handler :: GhciMonad m => SomeException -> m Bool
handler :: SomeException -> m Bool
handler SomeException
exception = do
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
flushInterpBuffers
  m Bool -> m Bool
forall (m :: Type -> Type) a.
(ExceptionMonad m, MonadIO m) =>
m a -> m a
withSignalHandlers (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
     (SomeException -> m Bool) -> m Bool -> m Bool
forall (m :: Type -> Type) a.
(HasDynFlags m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle SomeException -> m Bool
forall (m :: Type -> Type). GhciMonad m => SomeException -> m Bool
handler (SomeException -> m ()
forall (m :: Type -> Type). MonadIO m => SomeException -> m ()
showException SomeException
exception m () -> m Bool -> m Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False)

showException :: MonadIO m => SomeException -> m ()
showException :: SomeException -> m ()
showException SomeException
se =
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
           -- omit the location for CmdLineError:
           Just (CmdLineError String
s)    -> String -> IO ()
putException String
s
           -- ditto:
           Just GhcException
other_ghc_ex        -> String -> IO ()
putException (GhcException -> String
forall a. Show a => a -> String
show GhcException
other_ghc_ex)
           Maybe GhcException
Nothing                  ->
               case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se of
               Just AsyncException
UserInterrupt -> String -> IO ()
putException String
"Interrupted."
               Maybe AsyncException
_                  -> String -> IO ()
putException (String
"*** Exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
se)
  where
    putException :: String -> IO ()
putException = Handle -> String -> IO ()
hPutStrLn Handle
stderr


-----------------------------------------------------------------------------
-- recursive exception handlers

-- Don't forget to unblock async exceptions in the handler, or if we're
-- in an exception loop (eg. let a = error a in a) the ^C exception
-- may never be delivered.  Thanks to Marcin for pointing out the bug.

ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
ghciHandle :: (SomeException -> m a) -> m a -> m a
ghciHandle SomeException -> m a
h m a
m = ((m a -> m a) -> m a) -> m a
forall (m :: Type -> Type) a b.
ExceptionMonad m =>
((m a -> m a) -> m b) -> m b
gmask (((m a -> m a) -> m a) -> m a) -> ((m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \m a -> m a
restore -> do
                 -- Force dflags to avoid leaking the associated HscEnv
                 !DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
                 m a -> (SomeException -> m a) -> m a
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
gcatch (m a -> m a
restore (DynFlags -> m a -> m a
forall (m :: Type -> Type) a.
ExceptionMonad m =>
DynFlags -> m a -> m a
GHC.prettyPrintGhcErrors DynFlags
dflags m a
m)) ((SomeException -> m a) -> m a) -> (SomeException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> m a -> m a
restore (SomeException -> m a
h SomeException
e)

ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
ghciTry :: m a -> m (Either SomeException a)
ghciTry m a
m = (a -> Either SomeException a) -> m a -> m (Either SomeException a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either SomeException a
forall a b. b -> Either a b
Right m a
m m (Either SomeException a)
-> (SomeException -> m (Either SomeException a))
-> m (Either SomeException a)
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`gcatch` \SomeException
e -> Either SomeException a -> m (Either SomeException a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> Either SomeException a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
e

tryBool :: ExceptionMonad m => m a -> m Bool
tryBool :: m a -> m Bool
tryBool m a
m = do
    Either SomeException a
r <- m a -> m (Either SomeException a)
forall (m :: Type -> Type) a.
ExceptionMonad m =>
m a -> m (Either SomeException a)
ghciTry m a
m
    case Either SomeException a
r of
      Left SomeException
_  -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
      Right a
_ -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True

-- ----------------------------------------------------------------------------
-- Utils

lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule :: String -> m Module
lookupModule String
mName = ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
lookupModuleName (String -> ModuleName
GHC.mkModuleName String
mName)

lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
lookupModuleName :: ModuleName -> m Module
lookupModuleName ModuleName
mName = ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.lookupModule ModuleName
mName Maybe FastString
forall a. Maybe a
Nothing

isHomeModule :: Module -> Bool
isHomeModule :: Module -> Bool
isHomeModule Module
m = Module -> UnitId
GHC.moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mainUnitId

-- TODO: won't work if home dir is encoded.
-- (changeDirectory may not work either in that case.)
expandPath :: MonadIO m => String -> m String
expandPath :: String -> m String
expandPath = IO String -> m String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String)
-> (String -> IO String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
expandPathIO

expandPathIO :: String -> IO String
expandPathIO :: String -> IO String
expandPathIO String
p =
  case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
p of
   (Char
'~':String
d) -> do
        String
tilde <- IO String
getHomeDirectory -- will fail if HOME not defined
        String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
tilde String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
d)
   String
other ->
        String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
other

wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
wantInterpretedModule :: String -> m Module
wantInterpretedModule String
str = ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName (String -> ModuleName
GHC.mkModuleName String
str)

wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName :: ModuleName -> m Module
wantInterpretedModuleName ModuleName
modname = do
   Module
modl <- ModuleName -> m Module
forall (m :: Type -> Type). GhcMonad m => ModuleName -> m Module
lookupModuleName ModuleName
modname
   let str :: String
str = ModuleName -> String
moduleNameString ModuleName
modname
   DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
   Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Module -> UnitId
GHC.moduleUnitId Module
modl UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
thisPackage DynFlags
dflags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"module '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is from another package;\nthis command requires an interpreted module"))
   Bool
is_interpreted <- Module -> m Bool
forall (m :: Type -> Type). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
modl
   Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
is_interpreted) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
       GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"module '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not interpreted; try \':add *" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' first"))
   Module -> m Module
forall (m :: Type -> Type) a. Monad m => a -> m a
return Module
modl

wantNameFromInterpretedModule :: GHC.GhcMonad m
                              => (Name -> SDoc -> m ())
                              -> String
                              -> (Name -> m ())
                              -> m ()
wantNameFromInterpretedModule :: (Name -> MsgDoc -> m ()) -> String -> (Name -> m ()) -> m ()
wantNameFromInterpretedModule Name -> MsgDoc -> m ()
noCanDo String
str Name -> m ()
and_then =
  (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
   [Name]
names <- String -> m [Name]
forall (m :: Type -> Type). GhcMonad m => String -> m [Name]
GHC.parseName String
str
   case [Name]
names of
      []    -> () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      (Name
n:[Name]
_) -> do
            let modl :: Module
modl = ASSERT( isExternalName n ) GHC.nameModule n
            if Bool -> Bool
not (Name -> Bool
GHC.isExternalName Name
n)
               then Name -> MsgDoc -> m ()
noCanDo Name
n (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
n MsgDoc -> MsgDoc -> MsgDoc
<>
                                String -> MsgDoc
text String
" is not defined in an interpreted module"
               else do
            Bool
is_interpreted <- Module -> m Bool
forall (m :: Type -> Type). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
modl
            if Bool -> Bool
not Bool
is_interpreted
               then Name -> MsgDoc -> m ()
noCanDo Name
n (MsgDoc -> m ()) -> MsgDoc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"module " MsgDoc -> MsgDoc -> MsgDoc
<> Module -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Module
modl MsgDoc -> MsgDoc -> MsgDoc
<>
                                String -> MsgDoc
text String
" is not interpreted"
               else Name -> m ()
and_then Name
n

clearAllTargets :: GhciMonad m => m ()
clearAllTargets :: m ()
clearAllTargets = m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardActiveBreakPoints
                m () -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> [Target] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets []
                m () -> m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
LoadAllTargets
                m SuccessFlag -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()