{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS -fno-warn-name-shadowing #-}
-- This module does a lot of it

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

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

-- 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 GHC.Runtime.Debugger

-- The GHC interface
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
import GHC.ByteCode.Types
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.Driver.Errors
import GHC.Driver.Phases
import GHC.Driver.Session as DynFlags
import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
import GHC.Driver.Monad ( modifySession )
import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..),  TargetId(..),
             Resume, SingleStep, Ghc,
             GetDocsFailure(..), pushLogHookM,
             getModuleGraph, handleSourceError, ms_mod )
import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
import GHC.Hs.ImpExp
import GHC.Hs
import GHC.Driver.Env
import GHC.Runtime.Context
import GHC.Types.TyThing
import GHC.Types.TyThing.Ppr
import GHC.Core.TyCo.Ppr
import GHC.Types.SafeHaskell ( getSafeMode )
import GHC.Types.SourceError ( SourceError )
import GHC.Types.Name
import GHC.Types.Var ( varType )
import GHC.Iface.Syntax ( showToHeader )
import GHC.Builtin.Names
import GHC.Builtin.Types( stringTyCon_RDR )
import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
import GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Parser.Lexer as Lexer
import GHC.Parser.Header ( toArgs )
import qualified GHC.Parser.Header as Header
import GHC.Types.PkgQual

import GHC.Unit
import GHC.Unit.Finder as Finder
import GHC.Unit.Module.Graph (filterToposortToModules)
import GHC.Unit.Module.ModSummary

import GHC.Data.StringBuffer
import GHC.Utils.Outputable
import GHC.Utils.Logger

-- Other random utilities
import GHC.Types.Basic hiding ( isTopLevel )
import GHC.Data.Graph.Directed
import GHC.Utils.Encoding
import GHC.Data.FastString
import qualified GHC.Linker.Loader as Loader
import GHC.Data.Maybe ( orElse, expectJust )
import GHC.Types.Name.Set
import GHC.Utils.Panic hiding ( showException, try )
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Bag (unitBag)
import qualified GHC.Data.Strict as Strict

-- 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.Catch as MC
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 ( elemIndices, find, intercalate, intersperse, minimumBy,
                   isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import Data.Maybe
import qualified Data.Map as M
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Time.LocalTime ( getZonedTime )
import Data.Time.Format ( formatTime, defaultTimeLocale )
import Data.Version ( showVersion )
import qualified Data.Semigroup as S
import Prelude hiding ((<>))

import GHC.Utils.Exception as Exception hiding (catch, mask, handle)
import Foreign hiding (void)
import GHC.Stack hiding (SrcLoc(..))
import GHC.Unit.Env
import GHC.Unit.Home.ModInfo

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
import qualified GHC.Unit.Module.Graph as GHC

-- 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.Evaluator
import           Clash.GHC.GenerateBindings
import           Clash.GHC.NetlistTypes
import           Clash.GHC.PartialEval
import           Clash.GHCi.Common
import           Clash.Util (clashLibVersion, reportTimeDiff)
import           Data.Proxy
import qualified Data.Time.Clock as Clock
import qualified Paths_clash_ghc

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

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

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

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

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

  mkCmdHidden :: ([Char], [Char] -> InputT GHCi CmdExecOutcome) -> Command
mkCmdHidden ([Char]
n,[Char] -> InputT GHCi CmdExecOutcome
a) = Command { cmdName :: [Char]
cmdName = [Char]
n
                              , cmdAction :: [Char] -> InputT GHCi CmdExecOutcome
cmdAction = [Char] -> InputT GHCi CmdExecOutcome
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 :: [Char]
word_break_chars = [Char]
spaces [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
specials [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
symbols

word_break_chars_pred :: Char -> Bool
word_break_chars_pred :: Char -> Bool
word_break_chars_pred Char
'.' = Bool
False
word_break_chars_pred Char
c = Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ([Char]
spaces [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
specials) Bool -> Bool -> Bool
|| Char -> Bool
isSymbolChar Char
c

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

flagWordBreakChars :: String
flagWordBreakChars :: [Char]
flagWordBreakChars = [Char]
" \t\n"


showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String
showSDocForUser' :: forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUser' SDoc
doc = do
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    UnitState
unit_state <- (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState) -> m HscEnv -> m UnitState
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    NamePprCtx
name_ppr_ctx <- m NamePprCtx
forall (m :: Type -> Type). GhcMonad m => m NamePprCtx
GHC.getNamePprCtx
    [Char] -> m [Char]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitState -> NamePprCtx -> SDoc -> [Char]
showSDocForUser DynFlags
dflags UnitState
unit_state NamePprCtx
name_ppr_ctx SDoc
doc

showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String
showSDocForUserQualify :: forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUserQualify SDoc
doc = do
    DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    UnitState
unit_state <- (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState) -> m HscEnv -> m UnitState
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    [Char] -> m [Char]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitState -> NamePprCtx -> SDoc -> [Char]
showSDocForUser DynFlags
dflags UnitState
unit_state NamePprCtx
alwaysQualify SDoc
doc


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

keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
keepGoingMulti :: ([Char] -> GHCi ()) -> [Char] -> InputT GHCi CmdExecOutcome
keepGoingMulti [Char] -> GHCi ()
a [Char]
str = ([Char] -> InputT GHCi ()) -> [Char] -> InputT GHCi CmdExecOutcome
forall (m :: Type -> Type).
GhciMonad m =>
([Char] -> m ()) -> [Char] -> m CmdExecOutcome
keepGoingMulti' (GHCi () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi () -> InputT GHCi ())
-> ([Char] -> GHCi ()) -> [Char] -> InputT GHCi ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> GHCi ()
a) [Char]
str

keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome
keepGoing' :: forall (m :: Type -> Type) a.
GhciMonad m =>
(a -> m ()) -> a -> m CmdExecOutcome
keepGoing' a -> m ()
a a
str = do
  Bool
in_multi <- m Bool
forall (m :: Type -> Type). GhciMonad m => m Bool
inMultiMode
  if Bool
in_multi
    then
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Command is not supported (yet) in multi-mode"
    else
      a -> m ()
a a
str
  CmdExecOutcome -> m CmdExecOutcome
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdSuccess

-- For commands which are actually support in multi-mode, initially just :reload
keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome
keepGoingMulti' :: forall (m :: Type -> Type).
GhciMonad m =>
([Char] -> m ()) -> [Char] -> m CmdExecOutcome
keepGoingMulti' [Char] -> m ()
a [Char]
str = [Char] -> m ()
a [Char]
str m () -> m CmdExecOutcome -> m CmdExecOutcome
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> CmdExecOutcome -> m CmdExecOutcome
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdSuccess

inMultiMode :: GhciMonad m => m Bool
inMultiMode :: forall (m :: Type -> Type). GhciMonad m => m Bool
inMultiMode = GHCiState -> Bool
multiMode (GHCiState -> Bool) -> m GHCiState -> m Bool
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

keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
keepGoingPaths :: ([[Char]] -> InputT GHCi ())
-> [Char] -> InputT GHCi CmdExecOutcome
keepGoingPaths [[Char]] -> InputT GHCi ()
a [Char]
str
 = do case [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
str of
          Left [Char]
err -> IO CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall a. IO a -> InputT GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO CmdExecOutcome -> InputT GHCi CmdExecOutcome)
-> IO CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
err IO () -> IO CmdExecOutcome -> IO CmdExecOutcome
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> CmdExecOutcome -> IO CmdExecOutcome
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdSuccess
          Right [[Char]]
args -> ([[Char]] -> InputT GHCi ())
-> [[Char]] -> InputT GHCi CmdExecOutcome
forall (m :: Type -> Type) a.
GhciMonad m =>
(a -> m ()) -> a -> m CmdExecOutcome
keepGoing' [[Char]] -> InputT GHCi ()
a [[Char]]
args

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

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

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

findEditor :: IO String
findEditor :: IO [Char]
findEditor = do
    [Char] -> IO [Char]
getEnv [Char]
"VISUAL" IO [Char] -> IO [Char] -> IO [Char]
forall a. IO a -> IO a -> IO a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> [Char] -> IO [Char]
getEnv [Char]
"EDITOR" IO [Char] -> IO [Char] -> IO [Char]
forall a. IO a -> IO a -> IO a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> IO [Char]
defaultEditor
  where
    defaultEditor :: IO [Char]
defaultEditor = do
#if defined(mingw32_HOST_OS)
      win <- System.Win32.getWindowsDirectory
      return (win </> "notepad.exe")
#else
      [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Char]
""
#endif

default_progname, default_stop :: String
default_progname :: [Char]
default_progname = [Char]
"<interactive>"
default_stop :: [Char]
default_stop = [Char]
""

default_prompt, default_prompt_cont :: PromptFunction
default_prompt :: PromptFunction
default_prompt = [Char] -> PromptFunction
generatePromptFunctionFromString [Char]
"clashi> "
default_prompt_cont :: PromptFunction
default_prompt_cont = [Char] -> PromptFunction
generatePromptFunctionFromString [Char]
"clashi| "

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

interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String]
              -> Ghc ()
interactiveUI :: GhciSettings
-> [([Char], Maybe UnitId, Maybe Phase)]
-> Maybe [[Char]]
-> Ghc ()
interactiveUI GhciSettings
config [([Char], Maybe UnitId, Maybe Phase)]
srcs Maybe [[Char]]
maybe_exprs = do
   -- This is a HACK to make sure dynflags are not overwritten when setting
   -- options. When GHCi is made properly multi component it should be removed.
   (HscEnv -> HscEnv) -> Ghc ()
forall (m :: Type -> Type).
GhcMonad m =>
(HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
env -> (() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (HscEnv -> UnitId
hscActiveUnitId HscEnv
env) HscEnv
env)
   -- 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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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)
-> Ghc (ForeignHValue, ForeignHValue)
forall (m :: Type -> Type) a. GhcMonad m => m a -> m a
runInternal 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'
   Bool
_ <- DynFlags -> Ghc Bool
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags
               -- Set Opt_KeepGoing so that :reload loads as much as
               -- possible
               (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_KeepGoing)

   -- Update the LogAction. Ensure we don't override the user's log action lest
   -- we break -ddump-json (#14078)
   IORef [(FastString, Int)]
lastErrLocationsRef <- IO (IORef [(FastString, Int)]) -> Ghc (IORef [(FastString, Int)])
forall a. IO a -> Ghc a
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 []
   (LogAction -> LogAction) -> Ghc ()
forall (m :: Type -> Type).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM (IORef [(FastString, Int)] -> LogAction -> LogAction
ghciLogAction IORef [(FastString, Int)]
lastErrLocationsRef)

   Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe [[Char]] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [[Char]]
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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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

   [Char]
default_editor <- IO [Char] -> Ghc [Char]
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> Ghc [Char]) -> IO [Char] -> Ghc [Char]
forall a b. (a -> b) -> a -> b
$ IO [Char]
findEditor
   ForeignHValue
eval_wrapper <- [Char] -> [[Char]] -> Ghc ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> [[Char]] -> m ForeignHValue
mkEvalWrapper [Char]
default_progname [[Char]]
default_args
   let prelude_import :: ImportDecl GhcPs
prelude_import = ModuleName -> ImportDecl GhcPs
simpleImportDecl ModuleName
preludeModuleName
   HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
   let in_multi :: Bool
in_multi = Set UnitId -> Int
forall a. Set a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
   ModIfaceCache
empty_cache <- IO ModIfaceCache -> Ghc ModIfaceCache
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO ModIfaceCache
newIfaceCache
   GHCi () -> GHCiState -> Ghc ()
forall a. GHCi a -> GHCiState -> Ghc a
startGHCi ([([Char], Maybe UnitId, Maybe Phase)] -> Maybe [[Char]] -> GHCi ()
runGHCi [([Char], Maybe UnitId, Maybe Phase)]
srcs Maybe [[Char]]
maybe_exprs)
        GHCiState{ progname :: [Char]
progname           = [Char]
default_progname,
                   args :: [[Char]]
args               = [[Char]]
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 :: [Char]
stop               = [Char]
default_stop,
                   editor :: [Char]
editor             = [Char]
default_editor,
                   options :: [GHCiOption]
options            = [],
                   multiMode :: Bool
multiMode          = Bool
in_multi,
                   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 :: [[Char]]
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
prelude_import],
                   ghc_e :: Bool
ghc_e              = Maybe [[Char]] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [[Char]]
maybe_exprs,
                   short_help :: [Char]
short_help         = GhciSettings -> [Char]
shortHelpText GhciSettings
config,
                   long_help :: [Char]
long_help          = GhciSettings -> [Char]
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,
                   ifaceCache :: ModIfaceCache
ifaceCache = ModIfaceCache
empty_cache
                 }

   () -> Ghc ()
forall a. a -> Ghc a
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 :: forall (m :: Type -> Type). GhciMonad m => m ()
resetLastErrorLocations = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    IO () -> m ()
forall a. IO a -> m a
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 :: IORef [(FastString, Int)] -> LogAction -> LogAction
ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction
ghciLogAction IORef [(FastString, Int)]
lastErrLocations LogAction
old_log_action
              LogFlags
dflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg = do
    LogAction
old_log_action LogFlags
dflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
    case MessageClass
msg_class of
        MCDiagnostic Severity
SevError DiagnosticReason
_reason Maybe DiagnosticCode
_code -> case SrcSpan
srcSpan of
            RealSrcSpan RealSrcSpan
rsp Maybe BufSpan
_ -> 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 a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        MessageClass
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-- | Takes a file name and prefixes it with the appropriate
-- GHC appdir.
-- Uses ~/.ghc (getAppUserDataDirectory) if it exists
-- If it doesn't, then it uses $XDG_DATA_HOME/ghc
-- Earlier we always used to use ~/.ghc, but we want
-- to gradually move to $XDG_DATA_HOME to respect the XDG specification
--
-- As a migration strategy, we will only create new directories in
-- the appropriate XDG location. However, we will use the old directory
-- if it already exists.
getAppDataFile :: FilePath -> IO (Maybe FilePath)
getAppDataFile :: [Char] -> IO (Maybe [Char])
getAppDataFile [Char]
file = do
    let new_path :: IO (Maybe [Char])
new_path = IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO (XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgConfig [Char]
"clash") IO (Either IOException [Char])
-> (Either IOException [Char] -> IO (Maybe [Char]))
-> IO (Maybe [Char])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left IOException
_ -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
          Right [Char]
dir -> (IO (Maybe [Char])
 -> (IOException -> IO (Maybe [Char])) -> IO (Maybe [Char]))
-> (IOException -> IO (Maybe [Char]))
-> IO (Maybe [Char])
-> IO (Maybe [Char])
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe [Char])
-> (IOException -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (IO (Maybe [Char]) -> IOException -> IO (Maybe [Char])
forall a b. a -> b -> a
const (IO (Maybe [Char]) -> IOException -> IO (Maybe [Char]))
-> IO (Maybe [Char]) -> IOException -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing) (IO (Maybe [Char]) -> IO (Maybe [Char]))
-> IO (Maybe [Char]) -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
            Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False [Char]
dir
            Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
file

    Either IOException [Char]
e_old_path <- IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO ([Char] -> IO [Char]
getAppUserDataDirectory [Char]
"clash")
    case Either IOException [Char]
e_old_path of
      Right [Char]
old_path -> [Char] -> IO Bool
doesDirectoryExist [Char]
old_path IO Bool -> (Bool -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
old_path [Char] -> [Char] -> [Char]
</> [Char]
file
        Bool
False -> IO (Maybe [Char])
new_path
      Left IOException
_ -> IO (Maybe [Char])
new_path

runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi :: [([Char], Maybe UnitId, Maybe Phase)] -> Maybe [[Char]] -> GHCi ()
runGHCi [([Char], Maybe UnitId, Maybe Phase)]
paths Maybe [[Char]]
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 [Char])
app_user_dir = IO (Maybe [Char]) -> GHCi (Maybe [Char])
forall a. IO a -> GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> GHCi (Maybe [Char]))
-> IO (Maybe [Char]) -> GHCi (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
getAppDataFile [Char]
"clashi.conf"

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

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

   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile :: [Char] -> GHCi ()
sourceConfigFile [Char]
file = do
     Bool
exists <- IO Bool -> GHCi Bool
forall a. IO a -> GHCi a
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
$ [Char] -> IO Bool
doesFileExist [Char]
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 a. IO a -> GHCi a
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 ([Char] -> IOMode -> IO Handle
openFile [Char]
file IOMode
ReadMode)
       case Either IOException Handle
either_hdl of
         Left IOException
_e   -> () -> GHCi ()
forall a. a -> GHCi a
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 [Char]) -> InputT GHCi ()
runCommands (InputT GHCi (Maybe [Char]) -> InputT GHCi ())
-> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Handle -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe [Char])
fileLoop Handle
hdl
                IO () -> GHCi ()
forall a. IO a -> GHCi a
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 a. a -> IO a
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 [[Char]] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [[Char]]
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 a. IO a -> GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> GHCi ()) -> IO () -> GHCi ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"Loaded Clashi configuration from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file)

  --

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

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

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

      ([Char] -> GHCi ()) -> [[Char]] -> GHCi ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> GHCi ()
sourceConfigFile [[Char]]
userCfgs
        -- Process the global and user .ghci
        -- (but not $CWD/.ghci 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 [Char]
processedLocalCfg <- case Maybe [Char]
localCfg of
        Just [Char]
path | [Char]
path [Char] -> [[Char]] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [[Char]]
userCfgs ->
          -- don't read .ghci twice if CWD is $HOME
          case LocalConfigBehaviour
behaviour of
            LocalConfigBehaviour
SourceLocalConfig -> Maybe [Char]
localCfg Maybe [Char] -> GHCi () -> GHCi (Maybe [Char])
forall a b. a -> GHCi b -> GHCi a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ [Char] -> GHCi ()
sourceConfigFile [Char]
path
            LocalConfigBehaviour
IgnoreLocalConfig -> Maybe [Char] -> GHCi (Maybe [Char])
forall a. a -> GHCi a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
        Maybe [Char]
_ -> Maybe [Char] -> GHCi (Maybe [Char])
forall a. a -> GHCi a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing

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

  let arg_cfgs :: [[Char]]
arg_cfgs = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [[Char]]
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)

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

  -- Perform a :reload for files given on the GHCi command line
  -- The appropiate targets will already be set
  -- 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 ([([Char], Maybe UnitId, Maybe Phase)] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [([Char], Maybe UnitId, 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.
(HasLogger 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 a. a -> GHCi a
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
$
                    [([Char], Maybe UnitId, Maybe Phase)] -> GHCi SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule [([Char], Maybe UnitId, Maybe Phase)]
paths
     Bool -> GHCi () -> GHCi ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe [[Char]] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [[Char]]
maybe_exprs Bool -> Bool -> Bool
&& SuccessFlag -> Bool
failed SuccessFlag
ok) (GHCi () -> GHCi ()) -> GHCi () -> GHCi ()
forall a b. (a -> b) -> a -> b
$
        IO () -> GHCi ()
forall a. IO a -> GHCi a
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 [Char] -> Bool -> GHCi ()
forall (m :: Type -> Type).
GhciMonad m =>
Maybe [Char] -> Bool -> m ()
installInteractivePrint (DynFlags -> Maybe [Char]
interactivePrint DynFlags
dflags) (Maybe [[Char]] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [[Char]]
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 a. IO a -> GHCi a
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=0}

  case Maybe [[Char]]
maybe_exprs of
        Maybe [[Char]]
Nothing ->
          do
            -- Set different defaulting rules (See #280)
            [[Char]] -> GHCi ()
runGHCiExpressions
              [[Char]
"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 [Char]) -> InputT GHCi ()
runCommands (InputT GHCi (Maybe [Char]) -> InputT GHCi ())
-> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> InputT GHCi (Maybe [Char])
nextInputLine Bool
show_prompt Bool
is_tty
        Just [[Char]]
exprs -> do
            -- just evaluate the expression we were given
            [[Char]] -> GHCi ()
runGHCiExpressions [[Char]]
exprs

  -- and finally, exit
  IO () -> GHCi ()
forall a. IO a -> GHCi a
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
$ [Char] -> IO ()
putStrLn [Char]
"Leaving GHCi."

runGHCiExpressions :: [String] -> GHCi ()
runGHCiExpressions :: [[Char]] -> GHCi ()
runGHCiExpressions [[Char]]
exprs = do
            [[Char]] -> GHCi ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [[Char]]
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 a. IO a -> m a
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
$ [Char] -> IO b -> IO b
forall a. [Char] -> IO a -> IO a
withProgName (GHCiState -> [Char]
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 failure, see #7962, #9916, #17560, #18441
                ()
_ <- (SomeException -> GHCi Bool)
-> Maybe (GHCi ()) -> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
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 a b. GHCi a -> GHCi b -> GHCi b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> GHCi ()
forall a. a -> GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
                     (Maybe [Char] -> InputT GHCi (Maybe [Char])
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
                () -> InputT GHCi ()
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput :: forall a. 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
    [Char]
currentDirectory <- IO [Char] -> GHCi [Char]
forall a. IO a -> GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> GHCi [Char]) -> IO [Char] -> GHCi [Char]
forall a b. (a -> b) -> a -> b
$ IO [Char]
getCurrentDirectory

    Maybe [Char]
histFile <- case (Bool
ghciHistory, Bool
localGhciHistory) of
      (Bool
True, Bool
True) -> Maybe [Char] -> GHCi (Maybe [Char])
forall a. a -> GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
currentDirectory [Char] -> [Char] -> [Char]
</> [Char]
".clashi_history"))
      (Bool
True, Bool
_) -> IO (Maybe [Char]) -> GHCi (Maybe [Char])
forall a. IO a -> GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> GHCi (Maybe [Char]))
-> IO (Maybe [Char]) -> GHCi (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
getAppDataFile [Char]
"clashi_history"
      (Bool, Bool)
_ -> Maybe [Char] -> GHCi (Maybe [Char])
forall a. a -> GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
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 = 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 [Char])
nextInputLine Bool
show_prompt Bool
is_tty
  | Bool
is_tty = do
    [Char]
prmpt <- if Bool
show_prompt then GHCi [Char] -> InputT GHCi [Char]
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi [Char]
mkPrompt else [Char] -> InputT GHCi [Char]
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Char]
""
    Maybe [Char]
r <- [Char] -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
getInputLine [Char]
prmpt
    InputT GHCi ()
forall (m :: Type -> Type). GhciMonad m => m ()
incrementLineNo
    Maybe [Char] -> InputT GHCi (Maybe [Char])
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
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 [Char] -> InputT GHCi [Char]
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi [Char]
mkPrompt InputT GHCi [Char] -> ([Char] -> InputT GHCi ()) -> InputT GHCi ()
forall a b. InputT GHCi a -> (a -> InputT GHCi b) -> InputT GHCi b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> InputT GHCi ()
forall a. IO a -> InputT GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT GHCi ())
-> ([Char] -> IO ()) -> [Char] -> InputT GHCi ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStr
    Handle -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe [Char])
fileLoop Handle
stdin

-- NOTE: We only read .ghci 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 ./.ghci 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 :: [Char] -> IO Bool
checkFileAndDirPerms [Char]
file = do
  Bool
file_ok <- [Char] -> IO Bool
checkPerms [Char]
file
  -- Do not check dir perms when .ghci 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 [Char] -> IO Bool
checkPerms ([Char] -> [Char]
getDirectory [Char]
file) else Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
  where
  getDirectory :: [Char] -> [Char]
getDirectory [Char]
f = case [Char] -> [Char]
takeDirectory [Char]
f of
    [Char]
"" -> [Char]
"."
    [Char]
d -> [Char]
d

checkPerms :: FilePath -> IO Bool
#if defined(mingw32_HOST_OS)
checkPerms _ = return True
#else
checkPerms :: [Char] -> IO Bool
checkPerms [Char]
file =
  (IOException -> IO Bool) -> IO Bool -> IO Bool
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO (\IOException
_ -> Bool -> IO Bool
forall a. a -> IO a
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 <- [Char] -> IO FileStatus
getFileStatus [Char]
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.
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"*** WARNING: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
" is writable by someone else, IGNORING!" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
"\nSuggested fix: execute 'chmod go-w " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
ok
#endif

incrementLineNo :: GhciMonad m => m ()
incrementLineNo :: forall (m :: Type -> Type). GhciMonad m => 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 = line_number st + 1 }

fileLoop :: GhciMonad m => Handle -> m (Maybe String)
fileLoop :: forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe [Char])
fileLoop Handle
hdl = do
   Either IOException [Char]
l <- IO (Either IOException [Char]) -> m (Either IOException [Char])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException [Char]) -> m (Either IOException [Char]))
-> IO (Either IOException [Char]) -> m (Either IOException [Char])
forall a b. (a -> b) -> a -> b
$ IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO (IO [Char] -> IO (Either IOException [Char]))
-> IO [Char] -> IO (Either IOException [Char])
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
hdl
   case Either IOException [Char]
l of
        Left IOException
e | IOException -> Bool
isEOFError IOException
e              -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
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 [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
               | IOErrorType
InvalidArgument <- IOErrorType
etype  -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
               | Bool
otherwise                 -> IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> m (Maybe [Char]))
-> IO (Maybe [Char]) -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IOException -> IO (Maybe [Char])
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 [Char]
l' -> do
           m ()
forall (m :: Type -> Type). GhciMonad m => m ()
incrementLineNo
           Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
l')

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

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

getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
getInfoForPrompt :: forall (m :: Type -> Type). GhciMonad m => m (SDoc, [[Char]], 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

  SDoc
context_bit <-
        case [Resume]
resumes of
            [] -> SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SDoc
forall doc. IsOutput doc => doc
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 SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Resume -> SrcSpan
GHC.resumeSpan Resume
r)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space)
                   else do
                        let hist :: History
hist = Resume -> [History]
GHC.resumeHistory Resume
r [History] -> Int -> History
forall a. HasCallStack => [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
                        SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> Int
forall a. Num a => a -> a
negate Int
ix) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':'
                                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
pan) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space)

  let
        dots :: SDoc
dots | Resume
_:[Resume]
rs <- [Resume]
resumes, Bool -> Bool
not ([Resume] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Resume]
rs) = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"... "
             | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
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 XRec pass ModuleName
m <- ImportDecl pass -> Maybe (XRec pass ModuleName)
forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs ImportDecl pass
d = GenLocated l ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc XRec pass ModuleName
GenLocated l ModuleName
m
                      | Bool
otherwise           = GenLocated l ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
d)

        modules_names :: [[Char]]
modules_names =
             [Char
'*'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:(ModuleName -> [Char]
moduleNameString ModuleName
m) | IIModule ModuleName
m <- [InteractiveImport]
rev_imports] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
             [ModuleName -> [Char]
moduleNameString (ImportDecl GhcPs -> ModuleName
forall {pass} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName) =>
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

  (SDoc, [[Char]], Int) -> m (SDoc, [[Char]], Int)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc
dots SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
context_bit, [[Char]]
modules_names, Int
line)

-- | Takes a string, presumably following "%call", and tries to parse
-- a command and arguments in parentheses:
--
-- > parseCallEscape "  (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")
-- > parseCallEscape "( )rest" = Nothing
--
parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)
parseCallEscape :: [Char] -> Maybe (NonEmpty [Char], [Char])
parseCallEscape [Char]
s = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
s of
  Char
'(' : [Char]
sinceOpen -> case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') [Char]
sinceOpen of
    ([Char]
call, Char
')' : [Char]
sinceClosed)
      | [Char]
cmd : [[Char]]
args <- [Char] -> [[Char]]
words [Char]
call -> (NonEmpty [Char], [Char]) -> Maybe (NonEmpty [Char], [Char])
forall a. a -> Maybe a
Just ([Char]
cmd [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]]
args, [Char]
sinceClosed)
    ([Char], [Char])
_ -> Maybe (NonEmpty [Char], [Char])
forall a. Maybe a
Nothing
  [Char]
_ -> Maybe (NonEmpty [Char], [Char])
forall a. Maybe a
Nothing

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

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

mkPrompt :: GHCi String
mkPrompt :: GHCi [Char]
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
  (SDoc
context, [[Char]]
modules_names, Int
line) <- GHCi (SDoc, [[Char]], Int)
forall (m :: Type -> Type). GhciMonad m => m (SDoc, [[Char]], Int)
getInfoForPrompt

  SDoc
prompt_string <- (GHCiState -> PromptFunction
prompt GHCiState
st) [[Char]]
modules_names Int
line
  let prompt_doc :: SDoc
prompt_doc = SDoc
context SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
prompt_string

  [Char] -> GHCi [Char]
forall a. a -> GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags SDoc
prompt_doc)

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

-- Reconfigurable pretty-printing Ticket #5461
installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()
installInteractivePrint :: forall (m :: Type -> Type).
GhciMonad m =>
Maybe [Char] -> Bool -> m ()
installInteractivePrint Maybe [Char]
Nothing Bool
_  = () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
installInteractivePrint (Just [Char]
ipFun) Bool
exprmode = do
  SuccessFlag
ok <- m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
m SuccessFlag -> m SuccessFlag
trySuccess (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
                Name
name NE.:| [Name]
_ <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
ipFun
                (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 = new_ic})
                SuccessFlag -> m SuccessFlag
forall a. a -> m a
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 a. IO a -> m a
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 [Char]) -> InputT GHCi ()
runCommands InputT GHCi (Maybe [Char])
gCmd = (SomeException -> GHCi Bool)
-> Maybe (GHCi ()) -> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
runCommands' SomeException -> GHCi Bool
forall (m :: Type -> Type). GhciMonad m => SomeException -> m Bool
handler Maybe (GHCi ())
forall a. Maybe a
Nothing InputT GHCi (Maybe [Char])
gCmd InputT GHCi () -> InputT GHCi () -> InputT GHCi ()
forall a b. InputT GHCi a -> InputT GHCi b -> InputT GHCi b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> InputT GHCi ()
forall a. a -> InputT GHCi a
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 ()
runCommands' :: (SomeException -> GHCi Bool)
-> Maybe (GHCi ()) -> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
runCommands' SomeException -> GHCi Bool
eh Maybe (GHCi ())
sourceErrorHandler InputT GHCi (Maybe [Char])
gCmd = ((forall a. InputT GHCi a -> InputT GHCi a) -> InputT GHCi ())
-> InputT GHCi ()
forall b.
HasCallStack =>
((forall a. InputT GHCi a -> InputT GHCi a) -> InputT GHCi b)
-> InputT GHCi b
forall (m :: Type -> Type) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. InputT GHCi a -> InputT GHCi a) -> InputT GHCi ())
 -> InputT GHCi ())
-> ((forall a. InputT GHCi a -> InputT GHCi a) -> InputT GHCi ())
-> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ \forall a. InputT GHCi a -> InputT GHCi a
unmask -> do
    Maybe Bool
b <- (SomeException -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\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 a. a -> InputT GHCi a
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 a. IO a -> InputT GHCi a
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 a. a -> InputT GHCi a
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 a. IO a -> InputT GHCi a
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)
forall a. InputT GHCi a -> InputT GHCi a
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 [Char]) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
eh InputT GHCi (Maybe [Char])
gCmd)
    case Maybe Bool
b of
      Maybe Bool
Nothing -> () -> InputT GHCi ()
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      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 a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()) GHCi () -> InputT GHCi ()
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
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 () -> InputT GHCi ()
forall a. InputT GHCi a -> InputT GHCi a
unmask (InputT GHCi () -> InputT GHCi ())
-> InputT GHCi () -> InputT GHCi ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> GHCi Bool)
-> Maybe (GHCi ()) -> InputT GHCi (Maybe [Char]) -> InputT GHCi ()
runCommands' SomeException -> GHCi Bool
eh Maybe (GHCi ())
sourceErrorHandler InputT GHCi (Maybe [Char])
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.
-- TODO: replace Bool with CmdExecOutcome
runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
            -> InputT GHCi (Maybe Bool)
runOneCommand :: (SomeException -> GHCi Bool)
-> InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
eh InputT GHCi (Maybe [Char])
gCmd = do
  -- run a previously queued command if there is one, otherwise get new
  -- input from user
  Maybe [Char]
mb_cmd0 <- InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe [Char])
forall {m :: Type -> Type}.
GhciMonad m =>
m (Maybe [Char]) -> m (Maybe [Char])
noSpace (GHCi (Maybe [Char]) -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GHCi (Maybe [Char])
forall (m :: Type -> Type). GhciMonad m => m (Maybe [Char])
queryQueue)
  Maybe [Char]
mb_cmd1 <- InputT GHCi (Maybe [Char])
-> ([Char] -> InputT GHCi (Maybe [Char]))
-> Maybe [Char]
-> InputT GHCi (Maybe [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe [Char])
forall {m :: Type -> Type}.
GhciMonad m =>
m (Maybe [Char]) -> m (Maybe [Char])
noSpace InputT GHCi (Maybe [Char])
gCmd) (Maybe [Char] -> InputT GHCi (Maybe [Char])
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe [Char] -> InputT GHCi (Maybe [Char]))
-> ([Char] -> Maybe [Char]) -> [Char] -> InputT GHCi (Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just) Maybe [Char]
mb_cmd0
  case Maybe [Char]
mb_cmd1 of
    Maybe [Char]
Nothing -> Maybe Bool -> InputT GHCi (Maybe Bool)
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
    Just [Char]
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.
(HasLogger m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle (\SomeException
e -> GHCi (Maybe Bool) -> InputT GHCi (Maybe Bool)
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
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 a b. GHCi a -> (a -> GHCi b) -> GHCi b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Bool -> GHCi (Maybe Bool)
forall a. a -> GHCi a
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.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> InputT GHCi (Maybe Bool)
forall {m :: Type -> Type}.
(HasLogger m, MonadIO m, HasDynFlags 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
$ [Char] -> InputT GHCi CommandResult
doCommand [Char]
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).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
err
        Maybe Bool -> m (Maybe Bool)
forall a. a -> m a
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 [Char]) -> m (Maybe [Char])
noSpace m (Maybe [Char])
q = m (Maybe [Char])
q m (Maybe [Char])
-> (Maybe [Char] -> m (Maybe [Char])) -> m (Maybe [Char])
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe [Char])
-> ([Char] -> m (Maybe [Char])) -> Maybe [Char] -> m (Maybe [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
                            (\[Char]
c -> case [Char] -> [Char]
removeSpaces [Char]
c of
                                     [Char]
""   -> m (Maybe [Char]) -> m (Maybe [Char])
noSpace m (Maybe [Char])
q
                                     [Char]
":{" -> m (Maybe [Char]) -> m (Maybe [Char])
forall {m :: Type -> Type}.
GhciMonad m =>
m (Maybe [Char]) -> m (Maybe [Char])
multiLineCmd m (Maybe [Char])
q
                                     [Char]
_    -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
c) )
    multiLineCmd :: m (Maybe [Char]) -> m (Maybe [Char])
multiLineCmd m (Maybe [Char])
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 = prompt_cont st }
      Maybe [Char]
mb_cmd <- m (Maybe [Char]) -> [Char] -> m (Maybe [Char])
forall {m :: Type -> Type}.
MonadIO m =>
m (Maybe [Char]) -> [Char] -> m (Maybe [Char])
collectCommand m (Maybe [Char])
q [Char]
"" m (Maybe [Char]) -> m () -> m (Maybe [Char])
forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`MC.finally`
                (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st' -> GHCiState
st' { prompt = p })
      Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
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 [Char]) -> [Char] -> m (Maybe [Char])
collectCommand m (Maybe [Char])
q [Char]
c = m (Maybe [Char])
q m (Maybe [Char])
-> (Maybe [Char] -> m (Maybe [Char])) -> m (Maybe [Char])
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      m (Maybe [Char])
-> ([Char] -> m (Maybe [Char])) -> Maybe [Char] -> m (Maybe [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IOException -> IO (Maybe [Char])
forall a. IOException -> IO a
ioError IOException
collectError))
            (\[Char]
l->if [Char] -> [Char]
removeSpaces [Char]
l [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
":}"
                 then Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
c)
                 else m (Maybe [Char]) -> [Char] -> m (Maybe [Char])
collectCommand m (Maybe [Char])
q ([Char]
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
normSpace [Char]
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 = [Char] -> IOException
userError [Char]
"unterminated multiline command :{ .. :}"

    cmdOutcome :: CmdExecOutcome -> Maybe Bool
    cmdOutcome :: CmdExecOutcome -> Maybe Bool
cmdOutcome CmdExecOutcome
CleanExit = Maybe Bool
forall a. Maybe a
Nothing
    cmdOutcome CmdExecOutcome
CmdSuccess = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    cmdOutcome CmdExecOutcome
CmdFailure = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False

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

    -- command
    doCommand :: [Char] -> InputT GHCi CommandResult
doCommand [Char]
stmt | stmt' :: [Char]
stmt'@(Char
':' : [Char]
cmd) <- [Char] -> [Char]
removeSpaces [Char]
stmt = do
      (ActionStats
stats, Either SomeException CmdExecOutcome
result) <- (CmdExecOutcome -> Maybe Integer)
-> InputT GHCi CmdExecOutcome
-> InputT GHCi (ActionStats, Either SomeException CmdExecOutcome)
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(a -> Maybe Integer)
-> m a -> m (ActionStats, Either SomeException a)
runWithStats (Maybe Integer -> CmdExecOutcome -> Maybe Integer
forall a b. a -> b -> a
const Maybe Integer
forall a. Maybe a
Nothing) (InputT GHCi CmdExecOutcome
 -> InputT GHCi (ActionStats, Either SomeException CmdExecOutcome))
-> InputT GHCi CmdExecOutcome
-> InputT GHCi (ActionStats, Either SomeException CmdExecOutcome)
forall a b. (a -> b) -> a -> b
$ [Char] -> InputT GHCi CmdExecOutcome
specialCommand [Char]
cmd
      CommandResult -> InputT GHCi CommandResult
forall a. a -> InputT GHCi a
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
$ [Char]
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete [Char]
stmt' (CmdExecOutcome -> Maybe Bool
cmdOutcome (CmdExecOutcome -> Maybe Bool)
-> Either SomeException CmdExecOutcome
-> Either SomeException (Maybe Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SomeException CmdExecOutcome
result) ActionStats
stats

    -- haskell
    doCommand [Char]
stmt = do
      -- if 'stmt' was entered via ':{' it will contain '\n's
      let stmt_nl_cnt :: Int
stmt_nl_cnt = [()] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ () | Char
'\n' <- [Char]
stmt ]
      Bool
ml <- GHCi Bool -> InputT GHCi Bool
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
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 [Char]
mb_stmt <- [Char] -> InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe [Char]) -> m (Maybe [Char])
checkInputForLayout [Char]
stmt InputT GHCi (Maybe [Char])
gCmd
          case Maybe [Char]
mb_stmt of
            Maybe [Char]
Nothing -> CommandResult -> InputT GHCi CommandResult
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CommandResult
CommandIncomplete
            Just [Char]
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 (m :: Type -> Type) a. Monad m => m a -> InputT m a
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 -> [Char] -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
fst_line_num [Char]
ml_stmt SingleStep
GHC.RunToCompletion
              CommandResult -> InputT GHCi CommandResult
forall a. a -> InputT GHCi a
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
$
                [Char]
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete [Char]
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 a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ () | Char
'\n' <- [Char]
stmt' ]
              stmt' :: [Char]
stmt' = [Char] -> [Char]
dropLeadingWhiteLines [Char]
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 (m :: Type -> Type) a. Monad m => m a -> InputT m a
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 -> [Char] -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
fst_line_num [Char]
stmt' SingleStep
GHC.RunToCompletion
          CommandResult -> InputT GHCi CommandResult
forall a. a -> InputT GHCi a
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
$ [Char]
-> Either SomeException (Maybe Bool)
-> ActionStats
-> CommandResult
CommandComplete [Char]
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 -> [Char] -> SingleStep -> GHCi (Maybe ExecResult)
runStmtWithLineNum Int
lnum [Char]
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 = lnum }
        Maybe ExecResult
result <- [Char] -> SingleStep -> GHCi (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> SingleStep -> m (Maybe ExecResult)
runStmt [Char]
stmt SingleStep
step
        -- restore original line_number
        GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState GHCi GHCiState -> (GHCiState -> GHCi ()) -> GHCi ()
forall a b. GHCi a -> (a -> GHCi b) -> GHCi b
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 = line_number st0 }
        Maybe ExecResult -> GHCi (Maybe ExecResult)
forall a. a -> GHCi a
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 :: [Char] -> [Char]
dropLeadingWhiteLines [Char]
s | ([Char]
l0,Char
'\n':[Char]
r) <- (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') [Char]
s
                            , (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace [Char]
l0 = [Char] -> [Char]
dropLeadingWhiteLines [Char]
r
                            | Bool
otherwise = [Char]
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 :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe [Char]) -> m (Maybe [Char])
checkInputForLayout [Char]
stmt m (Maybe [Char])
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'   =  [Char] -> StringBuffer
stringToStringBuffer [Char]
stmt
       loc :: RealSrcLoc
loc    = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
fsLit (GHCiState -> [Char]
progname GHCiState
st0)) (GHCiState -> Int
line_number GHCiState
st0) Int
1
       pstate :: PState
pstate = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
Lexer.initParserState (DynFlags -> ParserOpts
initParserOpts 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 [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe [Char] -> m (Maybe [Char]))
-> Maybe [Char] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
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 = prompt_cont st1 }
       Maybe [Char]
mb_stmt <- (SomeException -> m (Maybe [Char]))
-> m (Maybe [Char]) -> m (Maybe [Char])
forall (m :: Type -> Type) a.
(HasLogger 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 [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
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 a. IO a -> m a
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 [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
                                 Maybe GhcException
_other -> IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO (Maybe [Char])
forall e a. Exception e => e -> IO a
Exception.throwIO SomeException
ex))
                     m (Maybe [Char])
getStmt
       (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st' -> GHCiState
st' { prompt = p })
       -- the recursive call does not recycle parser state
       -- as we use a new string buffer
       case Maybe [Char]
mb_stmt of
         Maybe [Char]
Nothing  -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
         Just [Char]
str -> if [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
""
           then Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe [Char] -> m (Maybe [Char]))
-> Maybe [Char] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
stmt
           else do
             [Char] -> m (Maybe [Char]) -> m (Maybe [Char])
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe [Char]) -> m (Maybe [Char])
checkInputForLayout ([Char]
stmt[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
str) m (Maybe [Char])
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 a. a -> P a
forall (m :: Type -> Type) a. Monad m => a -> m a
return P (Located Token) -> P Bool -> P Bool
forall a b. P a -> P b -> P b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> P Bool
goToEnd

enqueueCommands :: GhciMonad m => [String] -> m ()
enqueueCommands :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [[Char]]
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)
  [[Char]]
cmds [[Char]] -> m () -> m ()
forall a b. NFData a => a -> b -> b
`deepseq` () -> m ()
forall a. a -> m a
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 = cmds ++ cmdqueue 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 :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> SingleStep -> m (Maybe ExecResult)
runStmt [Char]
input SingleStep
step = do
  ParserOpts
pflags <- DynFlags -> ParserOpts
initParserOpts (DynFlags -> ParserOpts) -> m DynFlags -> m ParserOpts
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 GHC.Tc.Module
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  let source :: [Char]
source = GHCiState -> [Char]
progname GHCiState
st
  let line :: Int
line = GHCiState -> Int
line_number GHCiState
st

  -- Add any LANGUAGE/OPTIONS_GHC pragmas we find find.
  ParserOpts -> m ()
set_pragmas ParserOpts
pflags

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

     -- Otherwise assume a declaration (or a list of declarations)
     -- and/or import(s) (#20473).
     -- 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
         let !ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env  -- Bang-pattern to avoid space leaks
         InteractiveContext -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
InteractiveContext -> m ()
setDumpFilePrefix InteractiveContext
ic
           -- `-ddump-to-file` must work for normal GHCi compilations /
           --     evaluations. (#17500)
         -- Use >>= \case instead of MonadFail desugaring to take into
         -- consideration `instance XXModule p = DataConCantHappen`.
         -- Tracked in #15681
         IO (HsModule GhcPs) -> m (HsModule GhcPs)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> [Char] -> Int -> [Char] -> IO (HsModule GhcPs)
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line [Char]
input) m (HsModule GhcPs)
-> (HsModule GhcPs -> m (Maybe ExecResult)) -> m (Maybe ExecResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           HsModule { hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodDecls = [LHsDecl GhcPs]
decls, hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodImports = [LImportDecl GhcPs]
imports } -> do
             [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> m ()
forall {t :: Type -> Type} {m :: Type -> Type} {l}.
(Foldable t, GhciMonad m) =>
t (GenLocated l (ImportDecl GhcPs)) -> m ()
run_imports [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imports
             [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_imports :: t (GenLocated l (ImportDecl GhcPs)) -> m ()
run_imports t (GenLocated l (ImportDecl GhcPs))
imports = (GenLocated l (ImportDecl GhcPs) -> m ())
-> t (GenLocated l (ImportDecl GhcPs)) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ImportDecl GhcPs -> m ()
forall (m :: Type -> Type). GhciMonad m => ImportDecl GhcPs -> m ()
addImportToContext (ImportDecl GhcPs -> m ())
-> (GenLocated l (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated l (ImportDecl GhcPs)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) t (GenLocated l (ImportDecl GhcPs))
imports

    set_pragmas :: ParserOpts -> m ()
set_pragmas ParserOpts
pflags =
      let stringbuf :: StringBuffer
stringbuf = [Char] -> StringBuffer
stringToStringBuffer [Char]
input
          (Messages PsMessage
_msgs, [Located [Char]]
loc_opts) = ParserOpts
-> StringBuffer -> [Char] -> (Messages PsMessage, [Located [Char]])
Header.getOptions ParserOpts
pflags StringBuffer
stringbuf [Char]
"<interactive>"
          opts :: [[Char]]
opts = Located [Char] -> [Char]
forall l e. GenLocated l e -> e
unLoc (Located [Char] -> [Char]) -> [Located [Char]] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located [Char]]
loc_opts
      in [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
setOptions [[Char]]
opts

    run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
    run_stmt :: forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> m (Maybe ExecResult)
run_stmt GhciLStmt GhcPs
stmt = do
           Maybe ExecResult
m_result <- GhciLStmt GhcPs -> [Char] -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
GhciLStmt GhcPs -> [Char] -> SingleStep -> m (Maybe ExecResult)
GhciMonad.runStmt GhciLStmt GhcPs
stmt [Char]
input SingleStep
step
           case Maybe ExecResult
m_result of
               Maybe ExecResult
Nothing     -> Maybe ExecResult -> m (Maybe ExecResult)
forall a. a -> m a
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 :: forall (m :: Type -> Type).
GhciMonad m =>
[LHsDecl GhcPs] -> m (Maybe ExecResult)
run_decls [L SrcSpanAnnA
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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsBind GhcPs
bind)
    run_decls [L SrcSpanAnnA
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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
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 a. IO a -> m a
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
        la :: StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
la  = SrcSpanAnnA
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
        la' :: HsBind GhcPs -> GenLocated SrcSpanAnnA (HsBind GhcPs)
la' = SrcSpanAnnA
-> HsBind GhcPs -> GenLocated SrcSpanAnnA (HsBind GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc)
      in StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
la (XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsLocalBindsLR GhcPs GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
EpAnn AnnList
forall a. EpAnn a
noAnn (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 XValBinds GhcPs GhcPs
AnnSortKey
NoAnnSortKey (GenLocated SrcSpanAnnA (HsBind GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
forall a. a -> Bag a
unitBag (HsBind GhcPs -> GenLocated SrcSpanAnnA (HsBind GhcPs)
la' HsBind GhcPs
bind)) [])))

    setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500
    setDumpFilePrefix :: forall (m :: Type -> Type).
GhcMonad m =>
InteractiveContext -> m ()
setDumpFilePrefix InteractiveContext
ic = do
        DynFlags
dflags <- 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
dflags { dumpPrefix = modStr ++ "." }
      where
        modStr :: [Char]
modStr = ModuleName -> [Char]
moduleNameString (ModuleName -> [Char]) -> ModuleName -> [Char]
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> GenModule Unit
icInteractiveModule (InteractiveContext -> GenModule Unit)
-> InteractiveContext -> GenModule Unit
forall a b. (a -> b) -> a -> b
$ InteractiveContext
ic

-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: GhciMonad m
             => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
afterRunStmt :: forall (m :: Type -> Type).
GhciMonad m =>
(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 :: Either SomeException [Name]
execAllocation :: Word64
execResult :: ExecResult -> Either SomeException [Name]
execAllocation :: ExecResult -> Word64
..} ->
       case Either SomeException [Name]
execResult of
          Left SomeException
ex -> IO () -> m ()
forall a. IO a -> m a
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
         | Resume
first_resume : [Resume]
_ <- [Resume]
resumes
         , 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
first_resume) -> 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 :: [Char]
bCmd = [Char]
-> ((Int, BreakLocation) -> [Char])
-> Maybe (Int, BreakLocation)
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ( \(Int
_,BreakLocation
l) -> BreakLocation -> [Char]
onBreakCmd BreakLocation
l ) Maybe (Int, BreakLocation)
mb_id_loc
               if ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
bCmd)
                 then Resume -> [Name] -> m ()
forall (m :: Type -> Type). GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo Resume
first_resume [Name]
names
                 else [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [[Char]
bCmd]
               -- run the command set with ":set stop <cmd>"
               GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
               [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [GHCiState -> [Char]
stop GHCiState
st]
               () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
         | Bool
otherwise -> (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult
resume SrcSpan -> Bool
step_here SingleStep
GHC.SingleStep Maybe Int
forall a. Maybe a
Nothing m ExecResult -> (ExecResult -> m ExecResult) -> m ExecResult
forall a b. m a -> (a -> m b) -> m b
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 a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
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 => 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 a. a -> m a
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]
execResult :: ExecResult -> Either SomeException [Name]
execAllocation :: ExecResult -> Word64
execResult :: Either SomeException [Name]
execAllocation :: 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 :: forall (m :: Type -> Type).
GhciMonad m =>
Maybe BreakInfo -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation Maybe BreakInfo
Nothing = Maybe (Int, BreakLocation) -> m (Maybe (Int, BreakLocation))
forall a. a -> m a
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 :: GenModule Unit
md = BreakInfo -> GenModule Unit
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 a. a -> m a
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 -> GenModule Unit
breakModule BreakLocation
loc GenModule Unit -> GenModule Unit -> Bool
forall a. Eq a => a -> a -> Bool
== GenModule Unit
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 :: forall (m :: Type -> Type). GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo Resume
res [Name]
names = do
  SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ Resume -> SDoc
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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName [Name]
namesSorted
  [SDoc]
docs <- (Id -> m SDoc) -> [Id] -> m [SDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Id -> m SDoc
forall (m :: Type -> Type). GhcMonad m => Id -> m SDoc
pprTypeAndContents [Id
i | AnId Id
i <- [TyThing]
tythings]
  SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUserPartWay (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
docs

printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
printTypeOfNames :: forall (m :: Type -> Type). GhcMonad m => [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
compareNames :: Name -> Name -> Ordering
compareNames = ([Char] -> [Char] -> Ordering)
-> (Name -> [Char]) -> Name -> Name -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on [Char] -> [Char] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString (Name -> Name -> Ordering)
-> (Name -> Name -> Ordering) -> Name -> Name -> Ordering
forall a. Semigroup a => a -> a -> a
S.<> (SrcSpan -> SrcSpan -> Ordering)
-> (Name -> SrcSpan) -> Name -> Name -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan

printTypeOfName :: GHC.GhcMonad m => Name -> m ()
printTypeOfName :: forall (m :: Type -> Type). GhcMonad m => 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 a. a -> m a
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 CmdExecOutcome
specialCommand :: [Char] -> InputT GHCi CmdExecOutcome
specialCommand (Char
'!':[Char]
str) = GHCi CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi CmdExecOutcome -> InputT GHCi CmdExecOutcome)
-> GHCi CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall a b. (a -> b) -> a -> b
$ [Char] -> GHCi CmdExecOutcome
forall (m :: Type -> Type). MonadIO m => [Char] -> m CmdExecOutcome
shellEscape ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
str)
specialCommand [Char]
str = do
  let ([Char]
cmd,[Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace [Char]
str
  MaybeCommand
maybe_cmd <- [Char] -> InputT GHCi MaybeCommand
forall (m :: Type -> Type). GhciMonad m => [Char] -> m MaybeCommand
lookupCommand [Char]
cmd
  [Char]
htxt <- GHCiState -> [Char]
short_help (GHCiState -> [Char])
-> InputT GHCi GHCiState -> InputT GHCi [Char]
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 -> [Char] -> InputT GHCi CmdExecOutcome
cmdAction Command
cmd) ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
rest)
    MaybeCommand
BadCommand ->
      do IO () -> InputT GHCi ()
forall a. IO a -> InputT GHCi a
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 -> [Char] -> IO ()
hPutStr Handle
stderr ([Char]
"unknown command ':" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'\n"
                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
htxt)
         CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdFailure
    MaybeCommand
NoLastCommand ->
      do IO () -> InputT GHCi ()
forall a. IO a -> InputT GHCi a
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 -> [Char] -> IO ()
hPutStr Handle
stderr ([Char]
"there is no last command to perform\n"
                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
htxt)
         CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdFailure

shellEscape :: MonadIO m => String -> m CmdExecOutcome
shellEscape :: forall (m :: Type -> Type). MonadIO m => [Char] -> m CmdExecOutcome
shellEscape [Char]
str = IO CmdExecOutcome -> m CmdExecOutcome
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO CmdExecOutcome -> m CmdExecOutcome)
-> IO CmdExecOutcome -> m CmdExecOutcome
forall a b. (a -> b) -> a -> b
$ do
  ExitCode
exitCode <- [Char] -> IO ExitCode
system [Char]
str
  case ExitCode
exitCode of
    ExitCode
ExitSuccess -> CmdExecOutcome -> IO CmdExecOutcome
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdSuccess
    ExitFailure Int
_ -> CmdExecOutcome -> IO CmdExecOutcome
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdFailure

lookupCommand :: GhciMonad m => String -> m (MaybeCommand)
lookupCommand :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m MaybeCommand
lookupCommand [Char]
"" = 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 a. a -> m a
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MaybeCommand
NoLastCommand
lookupCommand [Char]
str = do
  Maybe Command
mc <- [Char] -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe Command)
lookupCommand' [Char]
str
  (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { last_command = mc })
  MaybeCommand -> m MaybeCommand
forall a. a -> m a
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' :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe Command)
lookupCommand' [Char]
":" = Maybe Command -> m (Maybe Command)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Command
forall a. Maybe a
Nothing
lookupCommand' [Char]
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 ([Char]
str, [Command]
xcmds) = case [Char]
str' of
          Char
':' : [Char]
rest -> ([Char]
rest, [])     -- "::" selects a builtin command
          [Char]
_          -> ([Char]
str', [Command]
macros) -- otherwise include macros in lookup

      lookupExact :: [Char] -> t Command -> Maybe Command
lookupExact  [Char]
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
$ ([Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==)              ([Char] -> Bool) -> (Command -> [Char]) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> [Char]
cmdName
      lookupPrefix :: [Char] -> t Command -> Maybe Command
lookupPrefix [Char]
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
$ ([Char]
s [Char] -> [Char] -> Bool
`isPrefixOptOf`) ([Char] -> Bool) -> (Command -> [Char]) -> Command -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> [Char]
cmdName

      -- hidden commands can only be matched exact
      builtinPfxMatch :: Maybe Command
builtinPfxMatch = [Char] -> [Command] -> Maybe Command
forall {t :: Type -> Type}.
Foldable t =>
[Char] -> t Command -> Maybe Command
lookupPrefix [Char]
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 a. a -> m a
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
$ [Char] -> [Command] -> Maybe Command
forall {t :: Type -> Type}.
Foldable t =>
[Char] -> t Command -> Maybe Command
lookupExact [Char]
str [Command]
xcmds Maybe Command -> Maybe Command -> Maybe Command
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           [Char] -> [Command] -> Maybe Command
forall {t :: Type -> Type}.
Foldable t =>
[Char] -> t Command -> Maybe Command
lookupExact [Char]
str [Command]
ghci_cmds Maybe Command -> Maybe Command -> Maybe Command
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           (Maybe Command
builtinPfxMatch Maybe Command -> (Command -> Maybe Command) -> Maybe Command
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Command
c -> [Char] -> [Command] -> Maybe Command
forall {t :: Type -> Type}.
Foldable t =>
[Char] -> t Command -> Maybe Command
lookupExact (Command -> [Char]
cmdName Command
c) [Command]
xcmds) Maybe Command -> Maybe Command -> Maybe Command
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           Maybe Command
builtinPfxMatch Maybe Command -> Maybe Command -> Maybe Command
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|>
           [Char] -> [Command] -> Maybe Command
forall {t :: Type -> Type}.
Foldable t =>
[Char] -> t Command -> Maybe Command
lookupPrefix [Char]
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 :: [Char] -> [Char] -> Bool
isPrefixOptOf [Char]
s [Char]
x = let ([Char]
body, [Char]
opt) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!') [Char]
s
                    in  ([Char]
body [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
x) Bool -> Bool -> Bool
&& ([Char]
opt [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
x)

getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan :: forall (m :: Type -> Type). GhcMonad m => 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 a. a -> m a
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 a. a -> m a
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. HasCallStack => [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 a. a -> m a
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 :: forall (m :: Type -> Type). GhcMonad m => m (Maybe [[Char]])
getCallStackAtCurrentBreakpoint = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case [Resume]
resumes of
    [] -> Maybe [[Char]] -> m (Maybe [[Char]])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [[Char]]
forall a. Maybe a
Nothing
    (Resume
r:[Resume]
_) -> do
       Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> m HscEnv -> m Interp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
       [[Char]] -> Maybe [[Char]]
forall a. a -> Maybe a
Just ([[Char]] -> Maybe [[Char]]) -> m [[Char]] -> m (Maybe [[Char]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Interp -> RemotePtr CostCentreStack -> IO [[Char]]
costCentreStackInfo Interp
interp (Resume -> RemotePtr CostCentreStack
GHC.resumeCCS Resume
r))

getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
getCurrentBreakModule :: forall (m :: Type -> Type).
GhcMonad m =>
m (Maybe (GenModule Unit))
getCurrentBreakModule = do
  [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
  case [Resume]
resumes of
    [] -> Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (GenModule Unit)
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 (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BreakInfo -> GenModule Unit
GHC.breakInfo_module (BreakInfo -> GenModule Unit)
-> Maybe BreakInfo -> Maybe (GenModule Unit)
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. HasCallStack => [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (GenModule Unit) -> m (Maybe (GenModule Unit)))
-> Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> Maybe (GenModule Unit)
forall a. a -> Maybe a
Just (GenModule Unit -> Maybe (GenModule Unit))
-> GenModule Unit -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ History -> GenModule Unit
GHC.getHistoryModule  History
hist

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

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

withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()
withSandboxOnly :: forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
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 SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
cmd SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                         [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"is not supported with -fno-ghci-sandbox")
      else m ()
this

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

help :: GhciMonad m => String -> m ()
help :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
help [Char]
_ = do
    [Char]
txt <- GHCiState -> [Char]
long_help (GHCiState -> [Char]) -> m GHCiState -> m [Char]
forall a b. (a -> b) -> m a -> m b
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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
txt

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

info :: GHC.GhcMonad m => Bool -> String -> m ()
info :: forall (m :: Type -> Type). GhcMonad m => Bool -> [Char] -> m ()
info Bool
_ [Char]
"" = GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"syntax: ':i <thing-you-want-info-about>'")
info Bool
allInfo [Char]
s  = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [[Char]] -> ([Char] -> m ()) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Char] -> [[Char]]
words [Char]
s) (([Char] -> m ()) -> m ()) -> ([Char] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[Char]
thing -> do
      SDoc
sdoc <- Bool -> [Char] -> m SDoc
forall (m :: Type -> Type). GhcMonad m => Bool -> [Char] -> m SDoc
infoThing Bool
allInfo [Char]
thing
      [Char]
rendered <- SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUser' SDoc
sdoc
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn [Char]
rendered)

infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
infoThing :: forall (m :: Type -> Type). GhcMonad m => Bool -> [Char] -> m SDoc
infoThing Bool
allInfo [Char]
str = do
    NonEmpty Name
names     <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
str
    NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
mb_stuffs <- (Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> NonEmpty Name
-> m (NonEmpty
        (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: Type -> Type).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
GHC.getInfo Bool
allInfo) NonEmpty Name
names
    let filtered :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filtered = ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> TyThing)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren (\(TyThing
t,Fixity
_f,[ClsInst]
_ci,[FamInst]
_fi,SDoc
_sd) -> TyThing
t)
                                     ([Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. [Maybe a] -> [a]
catMaybes (NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
mb_stuffs))
    SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"") ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc)
-> [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc
pprInfo [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
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 :: forall a. (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], SDoc) -> SDoc
pprInfo (TyThing
thing, Fixity
fixity, [ClsInst]
cls_insts, [FamInst]
fam_insts, SDoc
docs)
  =  SDoc
docs
  SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> SDoc
pprTyThingInContextLoc TyThing
thing
  SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> Fixity -> SDoc
showFixity TyThing
thing Fixity
fixity
  SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
GHC.pprInstance [ClsInst]
cls_insts)
  SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
GHC.pprFamInst  [FamInst]
fam_insts)

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

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

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

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

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

{-
Akin to @Prelude.words@, but acts like the Bourne shell, treating
quoted strings as Haskell Strings, and also parses Haskell [String]
syntax.
-}

getCmd :: String -> Either String             -- Error
                           (String, String) -- (Cmd, Rest)
getCmd :: [Char] -> Either [Char] ([Char], [Char])
getCmd [Char]
s = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
s of
           ([], [Char]
_) -> [Char] -> Either [Char] ([Char], [Char])
forall a b. a -> Either a b
Left ([Char]
"Couldn't find command in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s)
           ([Char], [Char])
res -> ([Char], [Char]) -> Either [Char] ([Char], [Char])
forall a b. b -> Either a b
Right ([Char], [Char])
res

toCmdArgs :: String -> Either String             -- Error
                              (String, [String]) -- (Cmd, Args)
toCmdArgs :: [Char] -> Either [Char] ([Char], [[Char]])
toCmdArgs [Char]
s = case [Char] -> Either [Char] ([Char], [Char])
getCmd [Char]
s of
              Left [Char]
err -> [Char] -> Either [Char] ([Char], [[Char]])
forall a b. a -> Either a b
Left [Char]
err
              Right ([Char]
cmd, [Char]
s') -> case [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
s' of
                                 Left [Char]
err -> [Char] -> Either [Char] ([Char], [[Char]])
forall a b. a -> Either a b
Left [Char]
err
                                 Right [[Char]]
args -> ([Char], [[Char]]) -> Either [Char] ([Char], [[Char]])
forall a b. b -> Either a b
Right ([Char]
cmd, [[Char]]
args)

-- wrapper around GHC.Parser.Header.toArgs, but without locations
toArgsNoLoc :: String -> Either String [String]
toArgsNoLoc :: [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
str = (Located [Char] -> [Char]) -> [Located [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Located [Char] -> [Char]
forall l e. GenLocated l e -> e
unLoc ([Located [Char]] -> [[Char]])
-> Either [Char] [Located [Char]] -> Either [Char] [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> RealSrcLoc -> [Char] -> Either [Char] [Located [Char]]
toArgs RealSrcLoc
fake_loc [Char]
str
  where
    fake_loc :: RealSrcLoc
fake_loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
fsLit [Char]
"<interactive>") Int
1 Int
1
    -- this should never be seen, because it's discarded with the `map unLoc`

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

changeDirectory :: GhciMonad m => String -> m ()
changeDirectory :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
changeDirectory [Char]
"" = do
  -- :cd on its own changes to the user's home directory
  Either IOException [Char]
either_dir <- IO (Either IOException [Char]) -> m (Either IOException [Char])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException [Char]) -> m (Either IOException [Char]))
-> IO (Either IOException [Char]) -> m (Either IOException [Char])
forall a b. (a -> b) -> a -> b
$ IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO IO [Char]
getHomeDirectory
  case Either IOException [Char]
either_dir of
     Left IOException
_e -> () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
     Right [Char]
dir -> [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
changeDirectory [Char]
dir
changeDirectory [Char]
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 a. [a] -> 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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
  -- delete defined breakpoints and clear the interface file cache (#1620)
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearCaches
  Bool -> Maybe ModuleGraph -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> Maybe ModuleGraph -> m ()
setContextAfterLoad Bool
False Maybe ModuleGraph
forall a. Maybe a
Nothing
  m ()
forall (m :: Type -> Type). GhcMonad m => m ()
GHC.workingDirectoryChanged
  [Char]
dir' <- [Char] -> m [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [Char]
dir
  IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
setCurrentDirectory [Char]
dir'
  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
  -- (this gives consistent behaviour with and without -fexternal-interpreter)
  Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> m HscEnv -> m Interp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  case Interp -> InterpInstance
interpInstance Interp
interp of
    ExternalInterp {} -> do
      ForeignHValue
fhv <- [Char] -> m ForeignHValue
forall (m :: Type -> Type). GhcMonad m => [Char] -> m ForeignHValue
compileGHCiExpr ([Char] -> m ForeignHValue) -> [Char] -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$
        [Char]
"System.Directory.setCurrentDirectory " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
dir'
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO ()
evalIO Interp
interp ForeignHValue
fhv
    InterpInstance
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

trySuccess :: GhciMonad m => m SuccessFlag -> m SuccessFlag
trySuccess :: forall (m :: Type -> Type).
GhciMonad m =>
m SuccessFlag -> m SuccessFlag
trySuccess m SuccessFlag
act =
    (SourceError -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit SourceError
e -- immediately exit fith failure if in ghc -e
                                SuccessFlag -> m SuccessFlag
forall a. a -> m a
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 :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
editFile [Char]
str =
  do [Char]
file <- if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
str then m [Char]
forall (m :: Type -> Type). GhcMonad m => m [Char]
chooseEditFile else [Char] -> m [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [Char]
str
     GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
     [(FastString, Int)]
errs <- IO [(FastString, Int)] -> m [(FastString, Int)]
forall a. IO a -> m a
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 :: [Char]
cmd = GHCiState -> [Char]
editor GHCiState
st
     Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
cmd)
       (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"editor not set, use :set editor")
     [Char]
lineOpt <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ do
         let sameFile :: [Char] -> [Char] -> IO Bool
sameFile [Char]
p1 [Char]
p2 = ([Char] -> [Char] -> Bool) -> IO [Char] -> IO [Char] -> IO Bool
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Char] -> IO [Char]
canonicalizePath [Char]
p1) ([Char] -> IO [Char]
canonicalizePath [Char]
p2)
              IO Bool -> (IOException -> IO Bool) -> IO Bool
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> Bool -> IO Bool
forall a. a -> IO a
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 -> [Char]
unpackFS FastString
f [Char] -> [Char] -> IO Bool
`sameFile` [Char]
file) [(FastString, Int)]
errs
         [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ case [(FastString, Int)]
curFileErrs of
             (FastString
_, Int
line):[(FastString, Int)]
_ -> [Char]
" +" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
line
             [(FastString, Int)]
_ -> [Char]
""
     let cmdArgs :: [Char]
cmdArgs = Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:([Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lineOpt)
     ExitCode
code <- IO ExitCode -> m ExitCode
forall a. IO a -> m a
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
$ [Char] -> IO ExitCode
system ([Char]
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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
$ [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
reloadModule [Char]
""

-- 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 dependency 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 occurred during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHC.GhcMonad m => m String
chooseEditFile :: forall (m :: Type -> Type). GhcMonad m => m [Char]
chooseEditFile =
  do let hasFailed :: ModuleGraphNode -> f Bool
hasFailed (GHC.ModuleNode [NodeKey]
_deps ModSummary
x) = (Bool -> Bool) -> f Bool -> f Bool
forall a b. (a -> b) -> f a -> f b
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
$ ModSummary -> f Bool
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m Bool
isLoadedModSummary ModSummary
x
         hasFailed ModuleGraphNode
_ = Bool -> f Bool
forall a. a -> f a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

     ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
     ModuleGraph
failed_graph <-
       [ModuleGraphNode] -> ModuleGraph
GHC.mkModuleGraph ([ModuleGraphNode] -> ModuleGraph)
-> m [ModuleGraphNode] -> m ModuleGraph
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleGraphNode -> m Bool)
-> [ModuleGraphNode] -> m [ModuleGraphNode]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleGraphNode -> m Bool
forall {f :: Type -> Type}. GhcMonad f => ModuleGraphNode -> f Bool
hasFailed (ModuleGraph -> [ModuleGraphNode]
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
$ [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
           Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ModuleGraph
g Maybe HomeUnitModule
forall a. Maybe a
Nothing
         pick :: [ModSummary] -> Maybe [Char]
pick [ModSummary]
xs  = case [ModSummary]
xs of
                      ModSummary
x : [ModSummary]
_ -> ModLocation -> Maybe [Char]
GHC.ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
x)
                      [ModSummary]
_     -> Maybe [Char]
forall a. Maybe a
Nothing

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

  where fromTarget :: Target -> Maybe [Char]
fromTarget GHC.Target { targetId :: Target -> TargetId
targetId = GHC.TargetFile [Char]
f Maybe Phase
_ } = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
f
        fromTarget Target
_ = Maybe [Char]
forall a. Maybe a
Nothing -- when would we get a module target?


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

defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
defineMacro :: forall (m :: Type -> Type). GhciMonad m => Bool -> [Char] -> m ()
defineMacro Bool
_ (Char
':':[Char]
_) = (IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr
                          [Char]
"macro name cannot start with a colon")
                            m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode
defineMacro Bool
_ (Char
'!':[Char]
_) = (IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr
                          [Char]
"macro name cannot start with an exclamation mark")
                            m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode
                          -- little code duplication allows to grep error msg
defineMacro Bool
overwrite [Char]
s = do
  let ([Char]
macro_name, [Char]
definition) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace [Char]
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 :: [[Char]]
defined = (Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
cmdName [Command]
macros
  if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
macro_name
        then if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [[Char]]
defined
                then IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"no macros defined"
                else IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr ([Char]
"the following macros are defined:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                      [[Char]] -> [Char]
unlines [[Char]]
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
<$> [Char] -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe Command)
lookupCommand' [Char]
macro_name
    let check_newname :: m ()
check_newname
          | [Char]
macro_name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [[Char]]
defined = GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError
            ([Char]
"macro '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
macro_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' is already defined. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hint))
          | Bool
isCommand = GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError
            ([Char]
"macro '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
macro_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' overwrites builtin command. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hint))
          | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        hint :: [Char]
hint = [Char]
" 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.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
step <- m (LHsExpr GhcPs)
m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: Type -> Type). GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr <- [Char] -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (LHsExpr GhcPs)
GHC.parseExpr [Char]
definition
      -- > ghciStepIO . definition :: String -> IO String
      let stringTy :: LHsType GhcPs
          stringTy :: LHsType GhcPs
stringTy = PromotionFlag -> IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP GhcPs
RdrName
stringTyCon_RDR
          ioM :: LHsType GhcPs -- AZ
          ioM :: LHsType GhcPs
ioM = PromotionFlag -> IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (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 (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
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
GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)
          tySig :: HsWildCardBndrs GhcPs (LocatedAn an (HsSigType GhcPs))
tySig = LocatedAn an (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (LocatedAn an (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (LocatedAn an (HsSigType GhcPs)
 -> HsWildCardBndrs GhcPs (LocatedAn an (HsSigType GhcPs)))
-> LocatedAn an (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (LocatedAn an (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ HsSigType GhcPs -> LocatedAn an (HsSigType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsSigType GhcPs -> LocatedAn an (HsSigType GhcPs))
-> HsSigType GhcPs -> LocatedAn an (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType (LHsType GhcPs -> HsSigType GhcPs)
-> LHsType GhcPs -> HsSigType GhcPs
forall a b. (a -> b) -> a -> b
$
                  LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy LHsType GhcPs
stringTy LHsType GhcPs
ioM
          new_expr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_expr = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr) (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr 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 XExprWithTySig GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
body LHsSigWcType (NoGhcTc GhcPs)
HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs))
forall {an}. HsWildCardBndrs GhcPs (LocatedAn an (HsSigType GhcPs))
tySig
      ForeignHValue
hv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
GHC.compileParsedExprRemote LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_expr

      let newCmd :: Command
newCmd = Command { cmdName :: [Char]
cmdName = [Char]
macro_name
                           , cmdAction :: [Char] -> InputT GHCi CmdExecOutcome
cmdAction = GHCi CmdExecOutcome -> InputT GHCi CmdExecOutcome
forall (m :: Type -> Type) a. Monad m => m a -> InputT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GHCi CmdExecOutcome -> InputT GHCi CmdExecOutcome)
-> ([Char] -> GHCi CmdExecOutcome)
-> [Char]
-> InputT GHCi CmdExecOutcome
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignHValue -> [Char] -> GHCi CmdExecOutcome
forall (m :: Type -> Type).
GhciMonad m =>
ForeignHValue -> [Char] -> m CmdExecOutcome
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 -> [Char]
cmdName Command
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
macro_name ]
        in GHCiState
s { ghci_macros = newCmd : filtered }

runMacro
  :: GhciMonad m
  => GHC.ForeignHValue  -- String -> IO String
  -> String
  -> m CmdExecOutcome
runMacro :: forall (m :: Type -> Type).
GhciMonad m =>
ForeignHValue -> [Char] -> m CmdExecOutcome
runMacro ForeignHValue
fun [Char]
s = do
  Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> m HscEnv -> m Interp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  [Char]
str <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> [Char] -> IO [Char]
evalStringToIOString Interp
interp ForeignHValue
fun [Char]
s
  [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands ([Char] -> [[Char]]
lines [Char]
str)
  CmdExecOutcome -> m CmdExecOutcome
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CmdSuccess


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

undefineMacro :: GhciMonad m => String -> m ()
undefineMacro :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
undefineMacro [Char]
str = ([Char] -> m ()) -> [[Char]] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
undef ([Char] -> [[Char]]
words [Char]
str)
 where undef :: [Char] -> m ()
undef [Char]
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 ([Char]
macro_name [Char] -> [[Char]] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` (Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
cmdName [Command]
cmds)
           then GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError
                ([Char]
"macro '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
macro_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' 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 = filter ((/= macro_name) . cmdName)
                                         (ghci_macros s) }


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

cmdCmd :: GhciMonad m => String -> m ()
cmdCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
cmdCmd [Char]
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
step <- m (LHsExpr GhcPs)
m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: Type -> Type). GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr <- [Char] -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (LHsExpr GhcPs)
GHC.parseExpr [Char]
str
    -- > ghciStepIO str :: IO String
    let new_expr :: LHsExpr GhcPs
new_expr = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
step LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
    ForeignHValue
hv <- LHsExpr GhcPs -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
GHC.compileParsedExprRemote LHsExpr GhcPs
new_expr

    Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> m HscEnv -> m Interp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    [Char]
cmds <- IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO [Char]
evalString Interp
interp ForeignHValue
hv
    [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands ([Char] -> [[Char]]
lines [Char]
cmds)

-- | Generate a typed ghciStepIO expression
-- @ghciStepIO :: Ty String -> IO String@.
getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO :: forall (m :: Type -> Type). GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO = do
  Name
ghciTyConName <- m Name
forall (m :: Type -> Type). GhcMonad m => m Name
GHC.getGHCiMonad
  let stringTy :: LHsType GhcPs
stringTy = PromotionFlag -> IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP GhcPs
RdrName
stringTyCon_RDR
      ghciM :: LHsType GhcPs
ghciM = PromotionFlag -> IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (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
GenLocated SrcSpanAnnA (HsType GhcPs)
stringTy
      ioM :: LHsType GhcPs
ioM = PromotionFlag -> IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (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
GenLocated SrcSpanAnnA (HsType GhcPs)
stringTy
      body :: LHsExpr GhcPs
body = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
ghciStepIoMName)
      tySig :: HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs))
tySig = LocatedAn AnnListItem (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (LocatedAn AnnListItem (HsSigType GhcPs)
 -> HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs)))
-> LocatedAn AnnListItem (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ HsSigType GhcPs -> LocatedAn AnnListItem (HsSigType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsSigType GhcPs -> LocatedAn AnnListItem (HsSigType GhcPs))
-> HsSigType GhcPs -> LocatedAn AnnListItem (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType (LHsType GhcPs -> HsSigType GhcPs)
-> LHsType GhcPs -> HsSigType GhcPs
forall a b. (a -> b) -> a -> b
$
              LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy LHsType GhcPs
ghciM LHsType GhcPs
ioM
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr 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 XExprWithTySig GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body LHsSigWcType (NoGhcTc GhcPs)
HsWildCardBndrs GhcPs (LocatedAn AnnListItem (HsSigType GhcPs))
tySig

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

checkModule :: GhciMonad m => String -> m ()
checkModule :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
checkModule [Char]
m = do
  let modl :: ModuleName
modl = [Char] -> ModuleName
GHC.mkModuleName [Char]
m
  Bool
ok <- (SourceError -> m Bool) -> m Bool -> m Bool
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit SourceError
e m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
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) = Bool -> ([Name], [Name]) -> ([Name], [Name])
forall a. HasCallStack => Bool -> a -> a
assert ((Name -> Bool) -> [Name] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Name -> Bool
isExternalName [Name]
scope) (([Name], [Name]) -> ([Name], [Name]))
-> ([Name], [Name]) -> ([Name], [Name])
forall a b. (a -> b) -> a -> b
$
                                  (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
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (GenModule Unit -> ModuleName)
-> (Name -> GenModule Unit) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
GHC.nameModule) [Name]
scope
                in
                        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"global names: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
glob) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"local  names: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
loc)
             ModuleInfo
_ -> SDoc
forall doc. IsOutput doc => doc
empty
          Bool -> m Bool
forall a. a -> m a
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 :: forall (m :: Type -> Type). GhcMonad m => [Char] -> m ()
docCmd [Char]
"" =
  GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"syntax: ':doc <thing-you-want-docs-for>'")
docCmd [Char]
s  = do
  -- TODO: Maybe also get module headers for module names
  NonEmpty Name
names <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
s

  NonEmpty DocComponents
docs <- (Name -> m DocComponents)
-> NonEmpty Name -> m (NonEmpty DocComponents)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse ([Char] -> Name -> m DocComponents
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Name -> m DocComponents
buildDocComponents [Char]
s) NonEmpty Name
names

  let sdocs :: [SDoc]
sdocs = [DocComponents] -> [SDoc]
pprDocs (NonEmpty DocComponents -> [DocComponents]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty DocComponents
docs)
      sdocs' :: SDoc
sdocs' = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"") [SDoc]
sdocs)
  [Char]
sdoc <- SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUser' SDoc
sdocs'
  IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn [Char]
sdoc)

data DocComponents =
  DocComponents
    { DocComponents -> Maybe [HsDoc GhcRn]
docs      :: Maybe [HsDoc GhcRn]   -- ^ subject's haddocks
    , DocComponents -> Maybe SDoc
sigAndLoc :: Maybe SDoc          -- ^ type signature + category + location
    , DocComponents -> IntMap (HsDoc GhcRn)
argDocs   :: IntMap (HsDoc GhcRn) -- ^ haddocks for arguments
    }

buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents
buildDocComponents :: forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Name -> m DocComponents
buildDocComponents [Char]
str Name
name = do
  Maybe TyThing
mbThing <- Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName Name
name
  let sigAndLoc :: Maybe SDoc
sigAndLoc = [Char] -> TyThing -> SDoc
sigAndLocDoc [Char]
str (TyThing -> SDoc) -> Maybe TyThing -> Maybe SDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TyThing
mbThing
  (Maybe [HsDoc GhcRn]
docs, IntMap (HsDoc GhcRn)
argDocs)
    <- (GetDocsFailure -> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> ((Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
    -> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> Either
     GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GetDocsFailure -> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall (m :: Type -> Type) a. GhcMonad m => GetDocsFailure -> m a
handleGetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
         (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
 -> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> m (Either
        GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-> m (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
-> m (Either
        GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
forall (m :: Type -> Type).
GhcMonad m =>
Name
-> m (Either
        GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
GHC.getDocs Name
name

  DocComponents -> m DocComponents
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DocComponents{Maybe [HsDoc GhcRn]
Maybe SDoc
IntMap (HsDoc GhcRn)
docs :: Maybe [HsDoc GhcRn]
sigAndLoc :: Maybe SDoc
argDocs :: IntMap (HsDoc GhcRn)
sigAndLoc :: Maybe SDoc
docs :: Maybe [HsDoc GhcRn]
argDocs :: IntMap (HsDoc GhcRn)
..}

-- | Produce output containing the type/kind signature, category, and definition
-- location of a TyThing.
sigAndLocDoc :: String -> TyThing -> SDoc
sigAndLocDoc :: [Char] -> TyThing -> SDoc
sigAndLocDoc [Char]
str TyThing
tyThing =
  let tyThingTyDoc :: TyThing -> SDoc
      tyThingTyDoc :: TyThing -> SDoc
tyThingTyDoc = \case
        AnId Id
i                      -> Type -> SDoc
pprSigmaType (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
i
        AConLike (RealDataCon DataCon
dc)   -> Type -> SDoc
pprSigmaType (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> DataCon -> Type
dataConDisplayType Bool
False DataCon
dc
        AConLike (PatSynCon PatSyn
patSyn) -> PatSyn -> SDoc
pprPatSynType PatSyn
patSyn
        ATyCon TyCon
tyCon                -> Type -> SDoc
pprSigmaType (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
GHC.tyConKind TyCon
tyCon
        ACoAxiom CoAxiom Branched
_                  -> SDoc
forall doc. IsOutput doc => doc
empty

      tyDoc :: SDoc
tyDoc = TyThing -> SDoc
tyThingTyDoc TyThing
tyThing
      sigDoc :: SDoc
sigDoc = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
str SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc -> SDoc
nest Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
tyDoc)
      comment :: SDoc
comment =
        [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\t' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"--"
             , TyThing -> SDoc
pprTyThingCategory TyThing
tyThing
             , [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"defined" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
pprNameDefnLoc (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tyThing)
             ]
   in SDoc -> Int -> SDoc -> SDoc
hang SDoc
sigDoc Int
2 SDoc
comment

pprDocs :: [DocComponents] -> [SDoc]
pprDocs :: [DocComponents] -> [SDoc]
pprDocs [DocComponents]
docs
  | [DocComponents] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DocComponents]
nonEmptyDocs = DocComponents -> SDoc
pprDoc (DocComponents -> SDoc) -> [DocComponents] -> [SDoc]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [DocComponents] -> [DocComponents]
forall a. Int -> [a] -> [a]
take Int
1 [DocComponents]
docs
  -- elide <has no documentation> if there's at least one non-empty doc (#15784)
  | Bool
otherwise = DocComponents -> SDoc
pprDoc (DocComponents -> SDoc) -> [DocComponents] -> [SDoc]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocComponents]
nonEmptyDocs
  where
    empty :: DocComponents -> Bool
empty DocComponents{docs :: DocComponents -> Maybe [HsDoc GhcRn]
docs = Maybe [HsDoc GhcRn]
mb_decl_docs, argDocs :: DocComponents -> IntMap (HsDoc GhcRn)
argDocs = IntMap (HsDoc GhcRn)
arg_docs}
      = Bool -> ([HsDoc GhcRn] -> Bool) -> Maybe [HsDoc GhcRn] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True [HsDoc GhcRn] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null Maybe [HsDoc GhcRn]
mb_decl_docs Bool -> Bool -> Bool
&& IntMap (HsDoc GhcRn) -> Bool
forall a. IntMap a -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null IntMap (HsDoc GhcRn)
arg_docs
    nonEmptyDocs :: [DocComponents]
nonEmptyDocs = (DocComponents -> Bool) -> [DocComponents] -> [DocComponents]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DocComponents -> Bool) -> DocComponents -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocComponents -> Bool
empty) [DocComponents]
docs

-- TODO: also print arg docs.
pprDoc :: DocComponents -> SDoc
pprDoc :: DocComponents -> SDoc
pprDoc DocComponents{sigAndLoc :: DocComponents -> Maybe SDoc
sigAndLoc = Maybe SDoc
mb_sig_loc, docs :: DocComponents -> Maybe [HsDoc GhcRn]
docs = Maybe [HsDoc GhcRn]
mb_decl_docs} =
  SDoc -> ([HsDoc GhcRn] -> SDoc) -> Maybe [HsDoc GhcRn] -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"<has no documentation>")
    [HsDoc GhcRn] -> SDoc
formatDoc
    Maybe [HsDoc GhcRn]
mb_decl_docs
  where
    formatDoc :: [HsDoc GhcRn] -> SDoc
formatDoc [HsDoc GhcRn]
doc =
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe SDoc
forall doc. IsOutput doc => doc
empty Maybe SDoc
mb_sig_loc -- print contextual info (#19055)
           , [HsDocString] -> SDoc
pprHsDocStrings ([HsDocString] -> SDoc) -> [HsDocString] -> SDoc
forall a b. (a -> b) -> a -> b
$ (HsDoc GhcRn -> HsDocString) -> [HsDoc GhcRn] -> [HsDocString]
forall a b. (a -> b) -> [a] -> [b]
map HsDoc GhcRn -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString [HsDoc GhcRn]
doc
           ]

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

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

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

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

-----------------------------------------------------------------------------
-- :load, :add, :unadd, :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 :: forall (m :: Type -> Type) a. GhcMonad m => m a -> m a
wrapDeferTypeErrors m a
load =
  m DynFlags -> (DynFlags -> m ()) -> (DynFlags -> m a) -> m a
forall (m :: Type -> Type) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
    (do
      -- Force originalFlags to avoid leaking the associated HscEnv
      !DynFlags
originalFlags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
      m Bool -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m Bool
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags (DynFlags -> m Bool) -> DynFlags -> m Bool
forall a b. (a -> b) -> a -> b
$
         GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' GeneralFlag
Opt_DeferTypeErrors DynFlags
originalFlags
      DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
originalFlags)
    (\DynFlags
originalFlags -> m Bool -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m Bool
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m Bool
GHC.setProgramDynFlags DynFlags
originalFlags)
    (\DynFlags
_ -> m a
load)

loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule :: forall (m :: Type -> Type).
GhciMonad m =>
[([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule [([Char], Maybe UnitId, 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) ([([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule' [([Char], Maybe UnitId, 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 a. IO a -> m a
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either SomeException SuccessFlag
result

-- | @:load@ command
loadModule_ :: GhciMonad m => [FilePath] -> m ()
loadModule_ :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
loadModule_ [[Char]]
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
$ [([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
[([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule ([[Char]]
-> [Maybe UnitId]
-> [Maybe Phase]
-> [([Char], Maybe UnitId, Maybe Phase)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [[Char]]
fs (Maybe UnitId -> [Maybe UnitId]
forall a. a -> [a]
repeat Maybe UnitId
forall a. Maybe a
Nothing) (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat Maybe Phase
forall a. Maybe a
Nothing))

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

loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule' :: forall (m :: Type -> Type).
GhciMonad m =>
[([Char], Maybe UnitId, Maybe Phase)] -> m SuccessFlag
loadModule' [([Char], Maybe UnitId, Maybe Phase)]
files = do
  let ([[Char]]
filenames, [Maybe UnitId]
uids, [Maybe Phase]
phases) = [([Char], Maybe UnitId, Maybe Phase)]
-> ([[Char]], [Maybe UnitId], [Maybe Phase])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([Char], Maybe UnitId, Maybe Phase)]
files
  [[Char]]
exp_filenames <- ([Char] -> m [Char]) -> [[Char]] -> m [[Char]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM [Char] -> m [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [[Char]]
filenames
  let files' :: [([Char], Maybe UnitId, Maybe Phase)]
files' = [[Char]]
-> [Maybe UnitId]
-> [Maybe Phase]
-> [([Char], Maybe UnitId, Maybe Phase)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [[Char]]
exp_filenames [Maybe UnitId]
uids [Maybe Phase]
phases
  [Target]
targets <- (([Char], Maybe UnitId, Maybe Phase) -> m Target)
-> [([Char], Maybe UnitId, 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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\([Char]
file, Maybe UnitId
uid, Maybe Phase
phase) -> [Char] -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget [Char]
file Maybe UnitId
uid Maybe Phase
phase) [([Char], Maybe UnitId, 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
  let !dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  let load_module :: m SuccessFlag
load_module = do
        -- unload first
        Bool
_ <- m Bool
forall (m :: Type -> Type). GhcMonad m => m Bool
GHC.abandonAll
        m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearCaches

        [Target] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
        Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
False LoadHowMuch
LoadAllTargets

  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciLeakCheck DynFlags
dflags
    then do
      -- Grab references to the currently loaded modules so that we can see if
      -- they leak.
      LeakIndicators
leak_indicators <- IO LeakIndicators -> m LeakIndicators
forall a. IO a -> m a
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
      SuccessFlag
success <- m SuccessFlag
load_module
      IO () -> m ()
forall a. IO a -> m a
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
success
    else
      m SuccessFlag
load_module

-- | @:add@ command
addModule :: GhciMonad m => [FilePath] -> m ()
addModule :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
addModule [[Char]]
files = do
  m ()
forall (m :: Type -> Type). GhciMonad m => m ()
revertCAFs -- always revert CAFs on load/add.
  [[Char]]
files' <- ([Char] -> m [Char]) -> [[Char]] -> m [[Char]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM [Char] -> m [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [[Char]]
files
  [Target]
targets <- ([Char] -> m Target) -> [[Char]] -> m [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\[Char]
m -> [Char] -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget [Char]
m Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing) [[Char]]
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). GhciMonad 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 :: Target -> TargetId
targetId = TargetId
tid } <- [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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  where
    checkTarget :: GhciMonad m => Target -> m Bool
    checkTarget :: forall (m :: Type -> Type). GhciMonad m => Target -> m Bool
checkTarget Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
m } = ModuleName -> m Bool
forall (m :: Type -> Type). GhciMonad m => ModuleName -> m Bool
checkTargetModule ModuleName
m
    checkTarget Target { targetId :: Target -> TargetId
targetId = TargetFile [Char]
f Maybe Phase
_ } = [Char] -> m Bool
forall (m :: Type -> Type). GhciMonad m => [Char] -> m Bool
checkTargetFile [Char]
f

    checkTargetModule :: GhciMonad m => ModuleName -> m Bool
    checkTargetModule :: forall (m :: Type -> Type). GhciMonad m => ModuleName -> m Bool
checkTargetModule ModuleName
m = do
      HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
      let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      FindResult
result <- IO FindResult -> m FindResult
forall a. IO a -> m a
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 -> PkgQual -> IO FindResult
Finder.findImportedModule HscEnv
hsc_env ModuleName
m (UnitId -> PkgQual
ThisPkg (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
      case FindResult
result of
        Found ModLocation
_ GenModule Unit
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
        FindResult
_ -> do IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"Module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString ModuleName
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not found")
                m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode
                Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

    checkTargetFile :: GhciMonad m => String -> m Bool
    checkTargetFile :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m Bool
checkTargetFile [Char]
f = do
      Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Bool
doesFileExist [Char]
f)
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
exists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"File " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not found"
      m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode
      Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
exists

-- | @:unadd@ command
unAddModule :: GhciMonad m => [FilePath] -> m ()
unAddModule :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
unAddModule [[Char]]
files = do
  [[Char]]
files' <- ([Char] -> m [Char]) -> [[Char]] -> m [[Char]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM [Char] -> m [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [[Char]]
files
  [Target]
targets <- ([Char] -> m Target) -> [[Char]] -> m [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\[Char]
m -> [Char] -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget [Char]
m Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing) [[Char]]
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 :: Target -> TargetId
targetId = TargetId
tid } <- [Target]
targets ]
  SuccessFlag
_ <- Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
False LoadHowMuch
LoadAllTargets
  () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-- | @:reload@ command
reloadModule :: GhciMonad m => String -> m ()
reloadModule :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
reloadModule [Char]
m = do
  HscEnv
session <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  let home_unit :: UnitId
home_unit = HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (HscEnv -> HomeUnit
hsc_home_unit HscEnv
session)
  SuccessFlag
ok <- Bool -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo Bool
True (UnitId -> LoadHowMuch
loadTargets UnitId
home_unit)
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok) m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode
  where
    loadTargets :: UnitId -> LoadHowMuch
loadTargets UnitId
hu | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
m    = LoadHowMuch
LoadAllTargets
                   | Bool
otherwise = HomeUnitModule -> LoadHowMuch
LoadUpTo (UnitId -> ModuleName -> HomeUnitModule
forall u. u -> ModuleName -> GenModule u
mkModule UnitId
hu ([Char] -> ModuleName
GHC.mkModuleName [Char]
m))

reloadModuleDefer :: GhciMonad m => String -> m ()
reloadModuleDefer :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
reloadModuleDefer = m () -> m ()
forall (m :: Type -> Type) a. GhcMonad m => m a -> m a
wrapDeferTypeErrors (m () -> m ()) -> ([Char] -> m ()) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> 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 :: forall (m :: Type -> Type).
GhciMonad m =>
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 a b. m a -> (a -> m b) -> m b
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
      -- MP: :set +c code path only works in single package mode atm, hence
      -- this call to isLoaded is ok. collectInfo needs to be modified further to
      -- work with :set +c so I have punted on that for now.
      [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 ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
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 = newInfos })
      SuccessFlag -> m SuccessFlag
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
Succeeded
    SuccessFlag
flag -> SuccessFlag -> m SuccessFlag
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuccessFlag
flag

doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
doLoad :: forall (m :: Type -> Type).
GhciMonad m =>
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 c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket (IO () -> m ()
forall a. IO a -> m a
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 a. IO a -> m a
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
      ModIfaceCache
hmis <- GHCiState -> ModIfaceCache
ifaceCache (GHCiState -> ModIfaceCache) -> m GHCiState -> m ModIfaceCache
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
      SuccessFlag
ok <- m SuccessFlag -> m SuccessFlag
forall (m :: Type -> Type).
GhciMonad m =>
m SuccessFlag -> m SuccessFlag
trySuccess (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
GHC.loadWithCache (ModIfaceCache -> Maybe ModIfaceCache
forall a. a -> Maybe a
Just ModIfaceCache
hmis) LoadHowMuch
howmuch
      SuccessFlag -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
SuccessFlag -> Bool -> m ()
afterLoad SuccessFlag
ok Bool
retain_context
      SuccessFlag -> m SuccessFlag
forall a. a -> m a
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 :: forall (m :: Type -> Type).
GhciMonad m =>
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
  ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
  Bool -> Maybe ModuleGraph -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> Maybe ModuleGraph -> m ()
setContextAfterLoad Bool
retain_context (ModuleGraph -> Maybe ModuleGraph
forall a. a -> Maybe a
Just ModuleGraph
graph)

setContextAfterLoad :: GhciMonad m => Bool -> Maybe GHC.ModuleGraph -> m ()
setContextAfterLoad :: forall (m :: Type -> Type).
GhciMonad m =>
Bool -> Maybe ModuleGraph -> m ()
setContextAfterLoad Bool
keep_ctxt Maybe ModuleGraph
Nothing = do
  Bool -> [InteractiveImport] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [InteractiveImport] -> m ()
setContextKeepingPackageModules Bool
keep_ctxt []
setContextAfterLoad Bool
keep_ctxt (Just ModuleGraph
graph) = 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
  [ModuleGraphNode]
loaded_graph <- (ModuleGraphNode -> m Bool)
-> [ModuleGraphNode] -> m [ModuleGraphNode]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleGraphNode -> m Bool
forall {f :: Type -> Type}. GhcMonad f => ModuleGraphNode -> f Bool
is_loaded ([ModuleGraphNode] -> m [ModuleGraphNode])
-> [ModuleGraphNode] -> m [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
GHC.mgModSummaries' ModuleGraph
graph
  case [ ModSummary
m | Just ModSummary
m <- (Target -> Maybe ModSummary) -> [Target] -> [Maybe ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ([ModuleGraphNode] -> Target -> Maybe ModSummary
findTarget [ModuleGraphNode]
loaded_graph) [Target]
targets ] of
        []    ->
          let graph' :: [ModSummary]
graph' = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
                Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ([ModuleGraphNode] -> ModuleGraph
GHC.mkModuleGraph [ModuleGraphNode]
loaded_graph) Maybe HomeUnitModule
forall a. Maybe a
Nothing
          in case [ModSummary]
graph' of
              [] -> Bool -> [InteractiveImport] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [InteractiveImport] -> m ()
setContextKeepingPackageModules Bool
keep_ctxt []
              [ModSummary]
xs -> ModSummary -> m ()
load_this ([ModSummary] -> ModSummary
forall a. HasCallStack => [a] -> a
last [ModSummary]
xs)
        (ModSummary
m:[ModSummary]
_) ->
          ModSummary -> m ()
load_this ModSummary
m
 where
   is_loaded :: ModuleGraphNode -> m Bool
is_loaded (GHC.ModuleNode [NodeKey]
_ ModSummary
ms) = ModSummary -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m Bool
isLoadedModSummary ModSummary
ms
   is_loaded ModuleGraphNode
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

   findTarget :: [ModuleGraphNode] -> Target -> Maybe ModSummary
findTarget [ModuleGraphNode]
mds Target
t
    = case (ModuleGraphNode -> Maybe ModSummary)
-> [ModuleGraphNode] -> [ModSummary]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModuleGraphNode -> Target -> Maybe ModSummary
`matches` Target
t) [ModuleGraphNode]
mds of
        []    -> Maybe ModSummary
forall a. Maybe a
Nothing
        (ModSummary
m:[ModSummary]
_) -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
m

   (GHC.ModuleNode [NodeKey]
_ ModSummary
summary) matches :: ModuleGraphNode -> Target -> Maybe ModSummary
`matches` Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
m }
        = if ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
summary ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m then ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
summary else Maybe ModSummary
forall a. Maybe a
Nothing
   (GHC.ModuleNode [NodeKey]
_ ModSummary
summary) `matches` Target { targetId :: Target -> TargetId
targetId = TargetFile [Char]
f Maybe Phase
_ }
        | Just [Char]
f' <- ModLocation -> Maybe [Char]
GHC.ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
summary)   =
          if [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
f' then ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
summary else Maybe ModSummary
forall a. Maybe a
Nothing
   ModuleGraphNode
_ `matches` Target
_ = Maybe ModSummary
forall a. Maybe a
Nothing

   load_this :: ModSummary -> m ()
load_this ModSummary
summary | GenModule Unit
m <- ModSummary -> GenModule Unit
GHC.ms_mod ModSummary
summary = do
        Bool
is_interp <- GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.moduleIsInterpreted GenModule Unit
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 (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName GenModule Unit
m)]
                    | Bool
otherwise = [ModuleName -> InteractiveImport
mkIIDecl   (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName GenModule Unit
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 :: forall (m :: Type -> Type).
GhciMonad m =>
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 a. a -> m a
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 = new_rem_ctx,
                   transient_ctx  = filterSubsumed new_rem_ctx 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 :: forall (m :: Type -> Type).
GhcMonad m =>
[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 :: forall (m :: Type -> Type).
GhcMonad m =>
InteractiveImport -> m Bool
is_pkg_import (IIModule ModuleName
_) = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
     is_pkg_import (IIDecl ImportDecl GhcPs
d)
         = do PkgQual
pkgqual <- ModuleName -> RawPkgQual -> m PkgQual
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> RawPkgQual -> m PkgQual
GHC.renameRawPkgQualM (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d) (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
d)
              Either SomeException (GenModule Unit)
e <- m (GenModule Unit) -> m (Either SomeException (GenModule Unit))
forall (m :: Type -> Type) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (m (GenModule Unit) -> m (Either SomeException (GenModule Unit)))
-> m (GenModule Unit) -> m (Either SomeException (GenModule Unit))
forall a b. (a -> b) -> a -> b
$ PkgQual -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
PkgQual -> ModuleName -> m (GenModule Unit)
GHC.findQualifiedModule PkgQual
pkgqual ModuleName
mod_name
              case Either SomeException (GenModule Unit)
e :: Either SomeException Module of
                Left SomeException
_  -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
                Right GenModule Unit
m -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> Bool
not (GenModule Unit -> Bool
isMainUnitModule GenModule Unit
m))
        where
          mod_name :: ModuleName
mod_name = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d)



modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
modulesLoadedMsg :: forall (m :: Type -> Type).
GhcMonad m =>
SuccessFlag -> [ModSummary] -> m ()
modulesLoadedMsg SuccessFlag
ok [ModSummary]
mods = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  SDoc
msg <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ShowLoadedModules DynFlags
dflags
         then do
               [SDoc]
mod_names <- (ModSummary -> m SDoc) -> [ModSummary] -> m [SDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ModSummary -> m SDoc
forall {m :: Type -> Type}. GhcMonad m => ModSummary -> m SDoc
mod_name [ModSummary]
mods
               let mod_commas :: SDoc
mod_commas
                     | [ModSummary] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [ModSummary]
mods = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"none."
                     | Bool
otherwise = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
mod_names) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"."
               SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
status SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
", modules loaded:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
mod_commas
         else do
               SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
status SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
","
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc -> SDoc
speakNOf ([ModSummary] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ModSummary]
mods) ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"module") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
"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
$ do
     [Char]
rendered_msg <- SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUser' SDoc
msg
     IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
rendered_msg
  where
    status :: SDoc
status = case SuccessFlag
ok of
                  SuccessFlag
Failed    -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Failed"
                  SuccessFlag
Succeeded -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Ok"

    mod_name :: ModSummary -> m SDoc
mod_name ModSummary
mod = do
        Bool
is_interpreted <- ModSummary -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m Bool
GHC.moduleIsBootOrNotObjectLinkable ModSummary
mod
        SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
is_interpreted
                 then GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> GenModule Unit
GHC.ms_mod ModSummary
mod)
                 else GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> GenModule Unit
GHC.ms_mod ModSummary
mod)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalise ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [Char]
msObjFilePath ModSummary
mod)
                      -- Fix #9887

-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
-- and printing 'throwE' strings to 'stderr'. If in expression
-- evaluation mode - throw GhcException and exit.
runExceptGhciMonad :: GhciMonad m => ExceptT SDoc m () -> m ()
runExceptGhciMonad :: forall (m :: Type -> Type).
GhciMonad m =>
ExceptT SDoc m () -> m ()
runExceptGhciMonad ExceptT SDoc m ()
act = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                         (SDoc -> m ()) -> (() -> m ()) -> Either SDoc () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SDoc -> m ()
forall {m :: Type -> Type}. GhciMonad m => SDoc -> m ()
handleErr () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either SDoc () -> m ()) -> m (Either SDoc ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                         ExceptT SDoc m () -> m (Either SDoc ())
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT SDoc m ()
act
  where
    handleErr :: SDoc -> m ()
handleErr SDoc
sdoc = do
        [Char]
rendered <- SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUserQualify SDoc
sdoc
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
rendered
        m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode

-- | Inverse of 'runExceptT' for \"pure\" computations
-- (c.f. 'except' for 'Except')
exceptT :: Applicative m => Either e a -> ExceptT e m a
exceptT :: forall (m :: Type -> Type) e a.
Applicative m =>
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 a. a -> m 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' :: forall backend.
Backend backend =>
Proxy backend -> IORef ClashOpts -> [[Char]] -> InputT GHCi ()
makeHDL' Proxy backend
backend IORef ClashOpts
opts [[Char]]
lst = [[Char]] -> InputT GHCi ()
go ([[Char]] -> InputT GHCi ())
-> InputT GHCi [[Char]] -> InputT GHCi ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< case [[Char]]
lst of
  srcs :: [[Char]]
srcs@([Char]
_:[[Char]]
_) -> [[Char]] -> InputT GHCi [[Char]]
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [[Char]]
srcs
  []         -> do
    ModuleGraph
modGraph <- InputT GHCi ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
    let sortedGraph :: [SCC ModSummary]
sortedGraph =
          -- TODO: this might break backpack
          [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
          Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
False ModuleGraph
modGraph Maybe HomeUnitModule
forall a. Maybe a
Nothing
    [[Char]] -> InputT GHCi [[Char]]
forall a. a -> InputT GHCi a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> InputT GHCi [[Char]])
-> [[Char]] -> InputT GHCi [[Char]]
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 [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (ModLocation -> Maybe [Char]
GHC.ml_hs_file (ModLocation -> Maybe [Char])
-> (ModSummary -> ModLocation) -> ModSummary -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
GHC.ms_location) ModSummary
top
      [SCC ModSummary]
_                      -> []
 where
  go :: [[Char]] -> InputT GHCi ()
go [[Char]]
srcs = do
    DynFlags
dflags <- InputT GHCi DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    DynFlags -> [[Char]] -> InputT GHCi ()
goX DynFlags
dflags [[Char]]
srcs InputT GHCi () -> InputT GHCi () -> InputT GHCi ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`MC.finally` DynFlags -> InputT GHCi ()
forall {m :: Type -> Type}. GhciMonad m => DynFlags -> m ()
recover DynFlags
dflags

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

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

makeHDL
  :: forall backend m
   . (GHC.GhcMonad m, Backend backend)
  => Proxy backend
  -> Ghc ()
  -> IORef ClashOpts
  -> [FilePath]
  -> m ()
makeHDL :: forall backend (m :: Type -> Type).
(GhcMonad m, Backend backend) =>
Proxy backend -> Ghc () -> IORef ClashOpts -> [[Char]] -> m ()
makeHDL Proxy backend
Proxy Ghc ()
startAction IORef ClashOpts
optsRef [[Char]]
srcs = do
  DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  IO () -> m ()
forall a. IO a -> m a
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 = useColor 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 [Char]
outputDir = do [Char]
odir <- DynFlags -> Maybe [Char]
objectDir DynFlags
dflags
                                 [Char]
hidir <- DynFlags -> Maybe [Char]
hiDir DynFlags
dflags
                                 [Char]
sdir <- DynFlags -> Maybe [Char]
stubDir DynFlags
dflags
                                 [Char]
ddir <- DynFlags -> Maybe [Char]
dumpDir DynFlags
dflags
                                 if ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
odir) [[Char]
hidir,[Char]
sdir,[Char]
ddir]
                                    then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
odir
                                    else Maybe [Char]
forall a. Maybe a
Nothing
                  idirs :: [[Char]]
idirs = DynFlags -> [[Char]]
importPaths DynFlags
dflags
                  opts2 :: ClashOpts
opts2 = ClashOpts
opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)
                                , opt_importPaths = idirs}
                  backend :: backend
backend = forall state. Backend state => ClashOpts -> state
initBackend @backend ClashOpts
opts2

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

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

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

                let getMain :: [Char] -> IO (TopEntityT, [TopEntityT])
getMain = HasCallStack =>
[Char] -> ClashDesign -> [Char] -> IO (TopEntityT, [TopEntityT])
[Char] -> ClashDesign -> [Char] -> IO (TopEntityT, [TopEntityT])
getMainTopEntity [Char]
src ClashDesign
clashDesign
                Maybe (TopEntityT, [TopEntityT])
mainTopEntity <- ([Char] -> IO (TopEntityT, [TopEntityT]))
-> Maybe [Char] -> 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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse [Char] -> IO (TopEntityT, [TopEntityT])
getMain (DynFlags -> Maybe [Char]
GHC.mainFunIs DynFlags
dflags)
                UTCTime
prepTime <- UTCTime
startTime UTCTime -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` ClashDesign -> BindingMap
designBindings ClashDesign
clashDesign BindingMap -> IO UTCTime -> IO UTCTime
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 :: [Char]
prepStartDiff = UTCTime -> UTCTime -> [Char]
reportTimeDiff UTCTime
prepTime UTCTime
startTime
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"GHC+Clash: Loading modules cumulatively took " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
prepStartDiff

                -- Generate HDL:
                ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either [Char] FilteredHWType)))
-> Evaluator
-> Evaluator
-> Maybe (TopEntityT, [TopEntityT])
-> UTCTime
-> IO ()
forall backend.
Backend backend =>
ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either [Char] 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 [Char] FilteredHWType))
ghcTypeToHWType Int
iw)
                  Evaluator
ghcEvaluator
                  Evaluator
evaluator
                  Maybe (TopEntityT, [TopEntityT])
mainTopEntity
                  UTCTime
startTime

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

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

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

-----------------------------------------------------------------------------
-- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.

typeOfExpr :: GhciMonad m => String -> m ()
typeOfExpr :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
typeOfExpr [Char]
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace [Char]
str of
      ([Char]
"+v", [Char]
_)    -> SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"`:type +v' has gone; use `:type' instead")
      ([Char]
"+d", [Char]
rest) -> TcRnExprMode -> [Char] -> m ()
forall {m :: Type -> Type}.
GhcMonad m =>
TcRnExprMode -> [Char] -> m ()
do_it TcRnExprMode
GHC.TM_Default ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
rest)
      ([Char], [Char])
_            -> TcRnExprMode -> [Char] -> m ()
forall {m :: Type -> Type}.
GhcMonad m =>
TcRnExprMode -> [Char] -> m ()
do_it TcRnExprMode
GHC.TM_Inst    [Char]
str
  where
    do_it :: TcRnExprMode -> [Char] -> m ()
do_it TcRnExprMode
mode [Char]
expr_str
      = do { Type
ty <- TcRnExprMode -> [Char] -> m Type
forall (m :: Type -> Type).
GhcMonad m =>
TcRnExprMode -> [Char] -> m Type
GHC.exprType TcRnExprMode
mode [Char]
expr_str
           ;    SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
expr_str
                                   , Int -> SDoc -> SDoc
nest Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
pprSigmaType Type
ty)] }

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

typeAtCmd :: GhciMonad m => String -> m ()
typeAtCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
typeAtCmd [Char]
str = ExceptT SDoc m () -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
ExceptT SDoc m () -> m ()
runExceptGhciMonad (ExceptT SDoc m () -> m ()) -> ExceptT SDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',[Char]
sample) <- Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either SDoc (RealSrcSpan, [Char])
 -> ExceptT SDoc m (RealSrcSpan, [Char]))
-> Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Either SDoc (RealSrcSpan, [Char])
parseSpanArg [Char]
str
    Map ModuleName ModInfo
infos      <- m (Map ModuleName ModInfo)
-> ExceptT SDoc m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
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 SDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT SDoc 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 -> [Char] -> ExceptT SDoc m (ModInfo, Type)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> [Char] -> ExceptT SDoc m (ModInfo, Type)
findType Map ModuleName ModInfo
infos RealSrcSpan
span' [Char]
sample
    m () -> ExceptT SDoc m ()
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT SDoc m ()) -> m () -> ExceptT SDoc m ()
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> SDoc -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
ModuleInfo -> SDoc -> m ()
printForUserModInfo (ModInfo -> ModuleInfo
modinfoInfo ModInfo
info)
                               ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
sample,Int -> SDoc -> SDoc
nest Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)])

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

usesCmd :: GhciMonad m => String -> m ()
usesCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
usesCmd [Char]
str = ExceptT SDoc m () -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
ExceptT SDoc m () -> m ()
runExceptGhciMonad (ExceptT SDoc m () -> m ()) -> ExceptT SDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',[Char]
sample) <- Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either SDoc (RealSrcSpan, [Char])
 -> ExceptT SDoc m (RealSrcSpan, [Char]))
-> Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Either SDoc (RealSrcSpan, [Char])
parseSpanArg [Char]
str
    Map ModuleName ModInfo
infos  <- m (Map ModuleName ModInfo)
-> ExceptT SDoc m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
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 SDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT SDoc 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 -> [Char] -> ExceptT SDoc m [SrcSpan]
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> [Char] -> ExceptT SDoc m [SrcSpan]
findNameUses Map ModuleName ModInfo
infos RealSrcSpan
span' [Char]
sample
    [SrcSpan] -> (SrcSpan -> ExceptT SDoc m ()) -> ExceptT SDoc 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 SDoc m ()
forall a. IO a -> ExceptT SDoc m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SDoc m ())
-> (SrcSpan -> IO ()) -> SrcSpan -> ExceptT SDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (SrcSpan -> [Char]) -> SrcSpan -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char]
showSrcSpan)

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

locAtCmd :: GhciMonad m => String -> m ()
locAtCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
locAtCmd [Char]
str = ExceptT SDoc m () -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
ExceptT SDoc m () -> m ()
runExceptGhciMonad (ExceptT SDoc m () -> m ()) -> ExceptT SDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (RealSrcSpan
span',[Char]
sample) <- Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
exceptT (Either SDoc (RealSrcSpan, [Char])
 -> ExceptT SDoc m (RealSrcSpan, [Char]))
-> Either SDoc (RealSrcSpan, [Char])
-> ExceptT SDoc m (RealSrcSpan, [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Either SDoc (RealSrcSpan, [Char])
parseSpanArg [Char]
str
    Map ModuleName ModInfo
infos    <- m (Map ModuleName ModInfo)
-> ExceptT SDoc m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
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 SDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT SDoc 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 -> [Char] -> ExceptT SDoc m (ModInfo, Name, SrcSpan)
forall (m :: Type -> Type).
GhcMonad m =>
Map ModuleName ModInfo
-> RealSrcSpan -> [Char] -> ExceptT SDoc m (ModInfo, Name, SrcSpan)
findLoc Map ModuleName ModInfo
infos RealSrcSpan
span' [Char]
sample
    IO () -> ExceptT SDoc m ()
forall a. IO a -> ExceptT SDoc m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SDoc m ())
-> (SrcSpan -> IO ()) -> SrcSpan -> ExceptT SDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (SrcSpan -> [Char]) -> SrcSpan -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char]
showSrcSpan (SrcSpan -> ExceptT SDoc m ()) -> SrcSpan -> ExceptT SDoc m ()
forall a b. (a -> b) -> a -> b
$ SrcSpan
sp

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

allTypesCmd :: GhciMonad m => String -> m ()
allTypesCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
allTypesCmd [Char]
_ = ExceptT SDoc m () -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
ExceptT SDoc m () -> m ()
runExceptGhciMonad (ExceptT SDoc m () -> m ()) -> ExceptT SDoc m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Map ModuleName ModInfo
infos <- m (Map ModuleName ModInfo)
-> ExceptT SDoc m (Map ModuleName ModInfo)
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
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 SDoc m (Map ModuleName ModInfo))
-> m (Map ModuleName ModInfo)
-> ExceptT SDoc 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 SDoc m ()) -> ExceptT SDoc 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 SDoc m ()) -> ExceptT SDoc m ())
-> (ModInfo -> ExceptT SDoc m ()) -> ExceptT SDoc m ()
forall a b. (a -> b) -> a -> b
$ \ModInfo
mi ->
        [SpanInfo] -> (SpanInfo -> ExceptT SDoc m ()) -> ExceptT SDoc 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 SDoc m ()
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT SDoc m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT SDoc m ())
-> (SpanInfo -> m ()) -> SpanInfo -> ExceptT SDoc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> m ()
forall {m :: Type -> Type}. GhcMonad m => SpanInfo -> m ()
printSpan)
  where
    printSpan :: SpanInfo -> m ()
printSpan SpanInfo
span'
      | Just Type
ty <- SpanInfo -> Maybe Type
spaninfoType SpanInfo
span' = do
        [Char]
tyInfo <- ([[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) ([Char] -> [Char]) -> m [Char] -> m [Char]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUserQualify (Type -> SDoc
pprSigmaType Type
ty)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Char] -> IO ()) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
            RealSrcSpan -> [Char]
showRealSrcSpan (SpanInfo -> RealSrcSpan
spaninfoSrcSpan SpanInfo
span') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tyInfo
      | Bool
otherwise = () -> m ()
forall a. a -> m a
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 :: [Char] -> Either SDoc (RealSrcSpan, [Char])
parseSpanArg [Char]
s = do
    ([Char]
fp,[Char]
s0) <- [Char] -> Either SDoc ([Char], [Char])
readAsString ([Char] -> [Char]
skipWs [Char]
s)
    [Char]
s0'     <- [Char] -> Either SDoc [Char]
skipWs1 [Char]
s0
    (Int
sl,[Char]
s1) <- [Char] -> Either SDoc (Int, [Char])
readAsInt [Char]
s0'
    [Char]
s1'     <- [Char] -> Either SDoc [Char]
skipWs1 [Char]
s1
    (Int
sc,[Char]
s2) <- [Char] -> Either SDoc (Int, [Char])
readAsInt [Char]
s1'
    [Char]
s2'     <- [Char] -> Either SDoc [Char]
skipWs1 [Char]
s2
    (Int
el,[Char]
s3) <- [Char] -> Either SDoc (Int, [Char])
readAsInt [Char]
s2'
    [Char]
s3'     <- [Char] -> Either SDoc [Char]
skipWs1 [Char]
s3
    (Int
ec,[Char]
s4) <- [Char] -> Either SDoc (Int, [Char])
readAsInt [Char]
s3'

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

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

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

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

    isWs :: Char -> Bool
isWs    = (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Char
' ',Char
'\t'])
    skipWs :: [Char] -> [Char]
skipWs  = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isWs
    breakWs :: [Char] -> ([Char], [Char])
breakWs = (Char -> Bool) -> [Char] -> ([Char], [Char])
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 -> [Char]
showSrcSpan (UnhelpfulSpan UnhelpfulSpanReason
s)  = FastString -> [Char]
unpackFS (UnhelpfulSpanReason -> FastString
unhelpfulSpanFS UnhelpfulSpanReason
s)
showSrcSpan (RealSrcSpan RealSrcSpan
spn Maybe BufSpan
_) = RealSrcSpan -> [Char]
showRealSrcSpan RealSrcSpan
spn

-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
showRealSrcSpan :: RealSrcSpan -> String
showRealSrcSpan :: RealSrcSpan -> [Char]
showRealSrcSpan RealSrcSpan
spn = [[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ [Char]
fp, [Char]
":(", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sl, [Char]
",", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sc
                             , [Char]
")-(", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
el, [Char]
",", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ec, [Char]
")"
                             ]
  where
    fp :: [Char]
fp = FastString -> [Char]
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 :: GhciMonad m => Bool -> String -> m ()
kindOfType :: forall (m :: Type -> Type). GhciMonad m => Bool -> [Char] -> m ()
kindOfType Bool
norm [Char]
str = (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (Type
ty, Type
kind) <- Bool -> [Char] -> m (Type, Type)
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> [Char] -> m (Type, Type)
GHC.typeKind Bool
norm [Char]
str
    SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
str SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
pprSigmaType Type
kind
                        , Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppWhen Bool
norm (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
pprSigmaType Type
ty ]

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

quit :: Monad m => String -> m CmdExecOutcome
quit :: forall (m :: Type -> Type). Monad m => [Char] -> m CmdExecOutcome
quit [Char]
_ = CmdExecOutcome -> m CmdExecOutcome
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CmdExecOutcome
CleanExit


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

-- running a script file #1363

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

-- | A version of 'words' that treats sequences enclosed in double quotes as
-- single words and that does not break on backslash-escaped spaces.
-- E.g., 'words\' "\"lorem ipsum\" dolor"' and 'words\' "lorem\\ ipsum dolor"'
-- yield '["lorem ipsum", "dolor"]'.
-- Used to scan for file paths in 'scriptCmd'.
words' :: String -> [String]
words' :: [Char] -> [[Char]]
words' [Char]
s = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
s of
  [Char]
"" -> []
  s' :: [Char]
s'@(Char
'\"' : [Char]
_) | [([Char]
w, [Char]
s'')] <- ReadS [Char]
forall a. Read a => ReadS a
reads [Char]
s' -> [Char]
w [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
words' [Char]
s''
  [Char]
s' -> ([Char] -> [Char]) -> [Char] -> [[Char]]
go [Char] -> [Char]
forall a. a -> a
id [Char]
s'
 where
  go :: ([Char] -> [Char]) -> [Char] -> [[Char]]
go [Char] -> [Char]
acc []                          = [[Char] -> [Char]
acc []]
  go [Char] -> [Char]
acc (Char
'\\' : Char
c : [Char]
cs) | Char -> Bool
isSpace Char
c = ([Char] -> [Char]) -> [Char] -> [[Char]]
go ([Char] -> [Char]
acc ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)) [Char]
cs
  go [Char] -> [Char]
acc (Char
c : [Char]
cs) | Char -> Bool
isSpace Char
c = [Char] -> [Char]
acc [] [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
words' [Char]
cs
                  | Bool
otherwise = ([Char] -> [Char]) -> [Char] -> [[Char]]
go ([Char] -> [Char]
acc ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)) [Char]
cs

runScript :: String    -- ^ filename
           -> InputT GHCi ()
runScript :: [Char] -> InputT GHCi ()
runScript [Char]
filename = do
  [Char]
filename' <- [Char] -> InputT GHCi [Char]
forall (m :: Type -> Type). MonadIO m => [Char] -> m [Char]
expandPath [Char]
filename
  Either IOException Handle
either_script <- IO (Either IOException Handle)
-> InputT GHCi (Either IOException Handle)
forall a. IO a -> InputT GHCi a
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 ([Char] -> IOMode -> IO Handle
openFile [Char]
filename' IOMode
ReadMode)
  case Either IOException Handle
either_script of
    Left IOException
_err    -> GhcException -> InputT GHCi ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ [Char]
"IO error:  \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
filename[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(IOException -> [Char]
ioeGetErrorString IOException
_err))
    Right Handle
script -> do
      GHCiState
st <- InputT GHCi GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
      let prog :: [Char]
prog = GHCiState -> [Char]
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=filename',line_number=0}
      Handle -> InputT GHCi ()
scriptLoop Handle
script
      IO () -> InputT GHCi ()
forall a. IO a -> InputT GHCi a
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=prog,line_number=line}
  where scriptLoop :: Handle -> InputT GHCi ()
scriptLoop Handle
script = do
          Maybe Bool
res <- (SomeException -> GHCi Bool)
-> InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe Bool)
runOneCommand SomeException -> GHCi Bool
forall (m :: Type -> Type). GhciMonad m => SomeException -> m Bool
handler (InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe Bool))
-> InputT GHCi (Maybe [Char]) -> InputT GHCi (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Handle -> InputT GHCi (Maybe [Char])
forall (m :: Type -> Type).
GhciMonad m =>
Handle -> m (Maybe [Char])
fileLoop Handle
script
          case Maybe Bool
res of
            Maybe Bool
Nothing -> () -> InputT GHCi ()
forall a. a -> InputT GHCi a
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 a. a -> InputT GHCi a
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 :: forall (m :: Type -> Type). GhcMonad m => [Char] -> m ()
isSafeCmd [Char]
m =
    case [Char] -> [[Char]]
words [Char]
m of
        [[Char]
s] | [Char] -> Bool
looksLikeModuleName [Char]
s -> do
            GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
lookupModule [Char]
s
            GenModule Unit -> m ()
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m ()
isSafeModule GenModule Unit
md
        [] -> do GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
guessCurrentModule [Char]
"issafe"
                 GenModule Unit -> m ()
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m ()
isSafeModule GenModule Unit
md
        [[Char]]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"syntax:  :issafe <module>")

isSafeModule :: GHC.GhcMonad m => Module -> m ()
isSafeModule :: forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m ()
isSafeModule GenModule Unit
m = do
    Maybe ModuleInfo
mb_mod_info <- GenModule Unit -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Maybe ModuleInfo)
GHC.getModuleInfo GenModule Unit
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
$ [Char] -> GhcException
CmdLineError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mname)

    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 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
$ [Char] -> GhcException
CmdLineError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ [Char]
"can't load interface file for module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    (ModuleName -> [Char]
GHC.moduleNameString (ModuleName -> [Char]) -> ModuleName -> [Char]
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName GenModule Unit
m))

    (Bool
msafe, Set UnitId
pkgs) <- GenModule Unit -> m (Bool, Set UnitId)
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Bool, Set UnitId)
GHC.moduleTrustReqs GenModule Unit
m
    let trust :: [Char]
trust  = SafeHaskellMode -> [Char]
forall a. Show a => a -> [Char]
show (SafeHaskellMode -> [Char]) -> SafeHaskellMode -> [Char]
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 :: [Char]
pkg    = if HscEnv -> GenModule Unit -> Bool
packageTrusted HscEnv
hsc_env GenModule Unit
m then [Char]
"trusted" else [Char]
"untrusted"
        (Set UnitId
good, Set UnitId
bad) = HscEnv -> Set UnitId -> (Set UnitId, Set UnitId)
tallyPkgs HscEnv
hsc_env Set UnitId
pkgs

    -- print info to user...
    IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Trust type is (Module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
trust [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", Package: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pkg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Package Trust: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if DynFlags -> Bool
packageTrustOn DynFlags
dflags then [Char]
"On" else [Char]
"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 UnitId -> Bool
forall a. Set a -> Bool
S.null Set UnitId
good)
         (IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Trusted package dependencies (trusted): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                        ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (UnitId -> [Char]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> UnitId -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
dflags) (Set UnitId -> [UnitId]
forall a. Set a -> [a]
S.toList Set UnitId
good)))
    case Bool
msafe Bool -> Bool -> Bool
&& Set UnitId -> Bool
forall a. Set a -> Bool
S.null Set UnitId
bad of
        Bool
True -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
mname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" 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 UnitId -> Bool
forall a. Set a -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null Set UnitId
bad)
                 (IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Trusted package dependencies (untrusted): "
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (UnitId -> [Char]) -> [UnitId] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> UnitId -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
dflags) (Set UnitId -> [UnitId]
forall a. Set a -> [a]
S.toList Set UnitId
bad)))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
mname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is NOT trusted!"

  where
    mname :: [Char]
mname = ModuleName -> [Char]
GHC.moduleNameString (ModuleName -> [Char]) -> ModuleName -> [Char]
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName GenModule Unit
m

    packageTrusted :: HscEnv -> GenModule Unit -> Bool
packageTrusted HscEnv
hsc_env GenModule Unit
md
        | HomeUnit -> GenModule Unit -> Bool
isHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) GenModule Unit
md = Bool
True
        | Bool
otherwise = GenericUnitInfo
  PackageId PackageName UnitId ModuleName (GenModule Unit)
-> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted (GenericUnitInfo
   PackageId PackageName UnitId ModuleName (GenModule Unit)
 -> Bool)
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
-> Bool
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) =>
UnitState
-> Unit
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
UnitState
-> Unit
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
unsafeLookupUnit ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env) (GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
md)

    tallyPkgs :: HscEnv -> Set UnitId -> (Set UnitId, Set UnitId)
tallyPkgs HscEnv
hsc_env Set UnitId
deps | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) = (Set UnitId
forall a. Set a
S.empty, Set UnitId
forall a. Set a
S.empty)
                          | Bool
otherwise = (UnitId -> Bool) -> Set UnitId -> (Set UnitId, Set UnitId)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
S.partition UnitId -> Bool
part Set UnitId
deps
        where part :: UnitId -> Bool
part UnitId
pkg   = GenericUnitInfo
  PackageId PackageName UnitId ModuleName (GenModule Unit)
-> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted (GenericUnitInfo
   PackageId PackageName UnitId ModuleName (GenModule Unit)
 -> Bool)
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
-> Bool
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) =>
UnitState
-> UnitId
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
UnitState
-> UnitId
-> GenericUnitInfo
     PackageId PackageName UnitId ModuleName (GenModule Unit)
unsafeLookupUnitId UnitState
unit_state UnitId
pkg
              unit_state :: UnitState
unit_state = (() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
              dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

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

-- Browsing a module's contents

browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()
browseCmd :: forall (m :: Type -> Type). GhcMonad m => Bool -> [Char] -> m ()
browseCmd Bool
bang [Char]
m =
  case [Char] -> [[Char]]
words [Char]
m of
    [Char
'*':[Char]
s] | [Char] -> Bool
looksLikeModuleName [Char]
s -> do
        GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
wantInterpretedModule [Char]
s
        Bool -> GenModule Unit -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> GenModule Unit -> Bool -> m ()
browseModule Bool
bang GenModule Unit
md Bool
False
    [[Char]
s] | [Char] -> Bool
looksLikeModuleName [Char]
s -> do
        GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
lookupModule [Char]
s
        Bool -> GenModule Unit -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> GenModule Unit -> Bool -> m ()
browseModule Bool
bang GenModule Unit
md Bool
True
    [] -> do GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
guessCurrentModule ([Char]
"browse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Bool
bang then [Char]
"!" else [Char]
"")
             Bool -> GenModule Unit -> Bool -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
Bool -> GenModule Unit -> Bool -> m ()
browseModule Bool
bang GenModule Unit
md Bool
True
    [[Char]]
_ -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"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 :: forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
guessCurrentModule [Char]
cmd = do
  [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
  case [InteractiveImport]
imports of
    [] -> GhcException -> m (GenModule Unit)
forall a. GhcException -> a
throwGhcException (GhcException -> m (GenModule Unit))
-> GhcException -> m (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
CmdLineError (Char
':' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": no current module")
    IIModule ModuleName
m : [InteractiveImport]
_ -> PkgQual -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
PkgQual -> ModuleName -> m (GenModule Unit)
GHC.findQualifiedModule PkgQual
NoPkgQual ModuleName
m
    IIDecl ImportDecl GhcPs
d : [InteractiveImport]
_ -> do
      PkgQual
pkgqual <- ModuleName -> RawPkgQual -> m PkgQual
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> RawPkgQual -> m PkgQual
GHC.renameRawPkgQualM (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d) (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
d)
      PkgQual -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
PkgQual -> ModuleName -> m (GenModule Unit)
GHC.findQualifiedModule PkgQual
pkgqual (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
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 :: forall (m :: Type -> Type).
GhcMonad m =>
Bool -> GenModule Unit -> Bool -> m ()
browseModule Bool
bang GenModule Unit
modl Bool
exports_only = do
  Maybe ModuleInfo
mb_mod_info <- GenModule Unit -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Maybe ModuleInfo)
GHC.getModuleInfo GenModule Unit
modl
  case Maybe ModuleInfo
mb_mod_info of
    Maybe ModuleInfo
Nothing -> GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError ([Char]
"unknown module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                ModuleName -> [Char]
GHC.moduleNameString (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName GenModule Unit
modl)))
    Just ModuleInfo
mod_info -> do
        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) = Bool -> ([Name], [Name]) -> ([Name], [Name])
forall a. HasCallStack => Bool -> a -> a
assert ((Name -> Bool) -> [Name] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Name -> Bool
isExternalName [Name]
names) (([Name], [Name]) -> ([Name], [Name]))
-> ([Name], [Name]) -> ([Name], [Name])
forall a b. (a -> b) -> a -> b
$
                                   (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((GenModule Unit -> GenModule Unit -> Bool
forall a. Eq a => a -> a -> Bool
==GenModule Unit
modl) (GenModule Unit -> Bool)
-> (Name -> GenModule Unit) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
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
SrcLoc.leftmost_smallest (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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [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 -> SDoc
pretty | Bool
bang      = ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader
                   | Bool
otherwise = ShowSub -> TyThing -> SDoc
pprTyThingInContext ShowSub
showToHeader

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

            qualifier :: Maybe [ModuleName] -> String
            qualifier :: Maybe [ModuleName] -> [Char]
qualifier  = [Char] -> ([ModuleName] -> [Char]) -> Maybe [ModuleName] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"-- defined locally"
                             (([Char]
"-- imported via "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> ([ModuleName] -> [Char]) -> [ModuleName] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", "
                               ([[Char]] -> [Char])
-> ([ModuleName] -> [[Char]]) -> [ModuleName] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> [Char]
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]], b)] -> [b]
annotate [([Maybe [ModuleName]], b)]
mts = (([Maybe [ModuleName]], [b]) -> [b])
-> [([Maybe [ModuleName]], [b])] -> [b]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (\([Maybe [ModuleName]]
m,[b]
ts)->[Maybe [ModuleName]] -> b
forall {doc}. IsLine doc => [Maybe [ModuleName]] -> doc
labels [Maybe [ModuleName]]
mb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
ts)
                         ([([Maybe [ModuleName]], [b])] -> [b])
-> [([Maybe [ModuleName]], [b])] -> [b]
forall a b. (a -> b) -> a -> b
$ (([Maybe [ModuleName]], [b])
 -> ([Maybe [ModuleName]], [b]) -> Ordering)
-> [([Maybe [ModuleName]], [b])] -> [([Maybe [ModuleName]], [b])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ([Maybe [ModuleName]], [b])
-> ([Maybe [ModuleName]], [b]) -> Ordering
forall {b}.
([Maybe [ModuleName]], b) -> ([Maybe [ModuleName]], b) -> Ordering
cmpQualifiers ([([Maybe [ModuleName]], [b])] -> [([Maybe [ModuleName]], [b])])
-> [([Maybe [ModuleName]], [b])] -> [([Maybe [ModuleName]], [b])]
forall a b. (a -> b) -> a -> b
$ [([Maybe [ModuleName]], b)] -> [([Maybe [ModuleName]], [b])]
forall {a} {b}. Eq a => [(a, b)] -> [(a, [b])]
grp [([Maybe [ModuleName]], b)]
mts
              where cmpQualifiers :: ([Maybe [ModuleName]], b) -> ([Maybe [ModuleName]], b) -> Ordering
cmpQualifiers =
                      [Maybe [[Char]]] -> [Maybe [[Char]]] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Maybe [[Char]]] -> [Maybe [[Char]]] -> Ordering)
-> (([Maybe [ModuleName]], b) -> [Maybe [[Char]]])
-> ([Maybe [ModuleName]], b)
-> ([Maybe [ModuleName]], b)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Maybe [ModuleName] -> Maybe [[Char]])
-> [Maybe [ModuleName]] -> [Maybe [[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map (([ModuleName] -> [[Char]]) -> Maybe [ModuleName] -> Maybe [[Char]]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> [Char]
unpackFS (FastString -> [Char])
-> (ModuleName -> FastString) -> ModuleName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FastString
moduleNameFS))) ([Maybe [ModuleName]] -> [Maybe [[Char]]])
-> (([Maybe [ModuleName]], b) -> [Maybe [ModuleName]])
-> ([Maybe [ModuleName]], b)
-> [Maybe [[Char]]]
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 :: [SDoc]
prettyThings = (TyThing -> SDoc) -> [TyThing] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> SDoc
pretty [TyThing]
things
            prettyThings' :: [SDoc]
prettyThings' | Bool
bang      = [([Maybe [ModuleName]], SDoc)] -> [SDoc]
forall {b}. IsLine b => [([Maybe [ModuleName]], b)] -> [b]
annotate ([([Maybe [ModuleName]], SDoc)] -> [SDoc])
-> [([Maybe [ModuleName]], SDoc)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ [[Maybe [ModuleName]]] -> [SDoc] -> [([Maybe [ModuleName]], SDoc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Maybe [ModuleName]]]
modNames [SDoc]
prettyThings
                          | Bool
otherwise = [SDoc]
prettyThings

        -- :browse reports qualifiers wrt current context
        [Char]
rendered_things <- SDoc -> m [Char]
forall (m :: Type -> Type). GhcMonad m => SDoc -> m [Char]
showSDocForUser' ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
prettyThings')
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
rendered_things
        -- 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 :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
moduleCmd [Char]
str
  | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all [Char] -> Bool
sensible [[Char]]
strs = m ()
cmd
  | Bool
otherwise = GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError [Char]
"syntax:  :module [+/-] [*]M1 ... [*]Mn")
  where
    (m ()
cmd, [[Char]]
strs) =
        case [Char]
str of
          Char
'+':[Char]
stuff -> ([ModuleName] -> [ModuleName] -> m ())
-> [Char] -> (m (), [[Char]])
forall {a}.
([ModuleName] -> [ModuleName] -> a) -> [Char] -> (a, [[Char]])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
addModulesToContext   [Char]
stuff
          Char
'-':[Char]
stuff -> ([ModuleName] -> [ModuleName] -> m ())
-> [Char] -> (m (), [[Char]])
forall {a}.
([ModuleName] -> [ModuleName] -> a) -> [Char] -> (a, [[Char]])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
remModulesFromContext [Char]
stuff
          [Char]
stuff     -> ([ModuleName] -> [ModuleName] -> m ())
-> [Char] -> (m (), [[Char]])
forall {a}.
([ModuleName] -> [ModuleName] -> a) -> [Char] -> (a, [[Char]])
rest [ModuleName] -> [ModuleName] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> [ModuleName] -> m ()
setContext            [Char]
stuff

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

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

    starred :: [Char] -> Either ModuleName ModuleName
starred (Char
'*':[Char]
m) = ModuleName -> Either ModuleName ModuleName
forall a b. a -> Either a b
Left  ([Char] -> ModuleName
GHC.mkModuleName [Char]
m)
    starred [Char]
m       = ModuleName -> Either ModuleName ModuleName
forall a b. b -> Either a b
Right ([Char] -> ModuleName
GHC.mkModuleName [Char]
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 :: forall (m :: Type -> Type).
GhciMonad m =>
[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_ :: forall (m :: Type -> Type).
GhciMonad m =>
[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 :: forall (m :: Type -> Type).
GhciMonad m =>
[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 :: forall (m :: Type -> Type). GhciMonad m => ModuleName -> m ()
rm ModuleName
str = do
     ModuleName
m <- GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName)
-> m (GenModule Unit) -> m ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
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 = filt (remembered_ctx st)
           , transient_ctx  = filt (transient_ctx st) }

setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
setContext :: forall (m :: Type -> Type).
GhciMonad m =>
[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 = [], 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 => ImportDecl GhcPs -> m ()
addImportToContext :: forall (m :: Type -> Type). GhciMonad m => ImportDecl GhcPs -> m ()
addImportToContext ImportDecl GhcPs
idecl = 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
  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 :: forall (m :: Type -> Type).
GhciMonad m =>
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 = addNotSubsumed iidecl (remembered_ctx st)
        , transient_ctx = filter (not . (iidecl `iiSubsumes`))
                                 (transient_ctx 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 :: forall (m :: Type -> Type) a. GhciMonad m => 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.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`MC.onException` ((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 = rc, transient_ctx = tc })

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

checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()
checkAdd :: forall (m :: Type -> Type). GhcMonad m => 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
$ [Char] -> GhcException
CmdLineError [Char]
"can't use * imports with Safe Haskell"
       | Bool
otherwise -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
wantInterpretedModuleName ModuleName
modname m (GenModule Unit) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

    IIDecl ImportDecl GhcPs
d -> do
       let modname :: ModuleName
modname = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d)
       PkgQual
pkgqual <- ModuleName -> RawPkgQual -> m PkgQual
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> RawPkgQual -> m PkgQual
GHC.renameRawPkgQualM ModuleName
modname (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
d)
       GenModule Unit
m <- PkgQual -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
PkgQual -> ModuleName -> m (GenModule Unit)
GHC.lookupQualifiedModule PkgQual
pkgqual ModuleName
modname
       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 <- GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.isModuleTrusted GenModule Unit
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
$ [Char] -> GhcException
ProgramError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ [Char]
""

-- -----------------------------------------------------------------------------
-- 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 :: forall (m :: Type -> Type). GhciMonad m => 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 :: forall (m :: Type -> Type).
GhciMonad m =>
[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 a. a -> m a
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
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)   = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d)

preludeModuleName :: ModuleName
preludeModuleName :: ModuleName
preludeModuleName = [Char] -> ModuleName
GHC.mkModuleName [Char]
"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) = GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
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
  =  GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d1) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
d2)
     Bool -> Bool -> Bool
&& ImportDecl GhcPs -> Maybe (XRec GhcPs ModuleName)
forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs ImportDecl GhcPs
d1 Maybe (GenLocated SrcSpanAnnA ModuleName)
-> Maybe (GenLocated SrcSpanAnnA ModuleName) -> Bool
forall a. Eq a => a -> a -> Bool
== ImportDecl GhcPs -> Maybe (XRec GhcPs ModuleName)
forall pass. ImportDecl pass -> Maybe (XRec pass 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 (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList ImportDecl GhcPs
d1 Maybe
  (ImportListInterpretation,
   GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
     (ImportListInterpretation,
      GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Bool
forall {a} {l}.
(Eq a, Eq l) =>
Maybe (ImportListInterpretation, GenLocated l [a])
-> Maybe (ImportListInterpretation, GenLocated l [a]) -> Bool
`hidingSubsumes` ImportDecl GhcPs
-> Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
ideclImportList ImportDecl GhcPs
d2)
  where
     Maybe (ImportListInterpretation, GenLocated l [a])
_                    hidingSubsumes :: Maybe (ImportListInterpretation, GenLocated l [a])
-> Maybe (ImportListInterpretation, GenLocated l [a]) -> Bool
`hidingSubsumes` Just (ImportListInterpretation
Exactly,L l
_ []) = Bool
True
     Just (ImportListInterpretation
Exactly, L l
_ [a]
xs) `hidingSubsumes` Just (ImportListInterpretation
Exactly,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 a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [a]
xs) [a]
ys
     Maybe (ImportListInterpretation, GenLocated l [a])
h1                   `hidingSubsumes` Maybe (ImportListInterpretation, GenLocated l [a])
h2              = Maybe (ImportListInterpretation, GenLocated l [a])
h1 Maybe (ImportListInterpretation, GenLocated l [a])
-> Maybe (ImportListInterpretation, GenLocated l [a]) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (ImportListInterpretation, 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 :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
setCmd [Char]
""   = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
False
setCmd [Char]
"-a" = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
True
setCmd [Char]
str
  = case [Char] -> Either [Char] ([Char], [Char])
getCmd [Char]
str of
    Right ([Char]
"args",    [Char]
rest) ->
        case [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
rest of
            Left [Char]
err -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
err)
            Right [[Char]]
args -> [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
setArgs [[Char]]
args
    Right ([Char]
"prog",    [Char]
rest) ->
        case [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
rest of
            Right [[Char]
prog] -> [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
setProg [Char]
prog
            Either [Char] [[Char]]
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"syntax: :set prog <progname>")

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

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

setiCmd :: GhciMonad m => String -> m ()
setiCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
setiCmd [Char]
""   = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall a. IO a -> m a
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 [Char]
"-a" = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall a. IO a -> m a
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 [Char]
str  =
  case [Char] -> Either [Char] [[Char]]
toArgsNoLoc [Char]
str of
    Left [Char]
err -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
err)
    Right [[Char]]
wds -> Bool -> [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [[Char]] -> m ()
newDynFlags Bool
True [[Char]]
wds

showOptions :: GhciMonad m => Bool -> m ()
showOptions :: forall (m :: Type -> Type). GhciMonad m => 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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn (DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (
              [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"options currently set: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
              if [GHCiOption] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [GHCiOption]
opts
                   then [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"none."
                   else [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((GHCiOption -> SDoc) -> [GHCiOption] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\GHCiOption
o -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (GHCiOption -> [Char]
optToStr GHCiOption
o)) [GHCiOption]
opts)
           ))
       IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> DynFlags -> IO ()
showDynFlags Bool
show_all DynFlags
dflags


showDynFlags :: Bool -> DynFlags -> IO ()
showDynFlags :: Bool -> DynFlags -> IO ()
showDynFlags Bool
show_all DynFlags
dflags = do
  Bool -> DynFlags -> IO ()
showLanguages' Bool
show_all DynFlags
dflags
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$
     [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"GHCi-specific dynamic flag settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FlagSpec GeneralFlag -> SDoc) -> [FlagSpec GeneralFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> [Char]
-> (GeneralFlag -> DynFlags -> Bool)
-> FlagSpec GeneralFlag
-> SDoc
forall flag.
[Char]
-> [Char] -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting [Char]
"-f" [Char]
"-fno-" GeneralFlag -> DynFlags -> Bool
gopt) [FlagSpec GeneralFlag]
ghciFlags))
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$
     [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"other dynamic, non-language, flag settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FlagSpec GeneralFlag -> SDoc) -> [FlagSpec GeneralFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> [Char]
-> (GeneralFlag -> DynFlags -> Bool)
-> FlagSpec GeneralFlag
-> SDoc
forall flag.
[Char]
-> [Char] -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting [Char]
"-f" [Char]
"-fno-" GeneralFlag -> DynFlags -> Bool
gopt) [FlagSpec GeneralFlag]
others))
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$
     [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"warning settings:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FlagSpec WarningFlag -> SDoc) -> [FlagSpec WarningFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> [Char]
-> (WarningFlag -> DynFlags -> Bool)
-> FlagSpec WarningFlag
-> SDoc
forall flag.
[Char]
-> [Char] -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting [Char]
"-W" [Char]
"-Wno-" WarningFlag -> DynFlags -> Bool
wopt) [FlagSpec WarningFlag]
DynFlags.wWarningFlags))
  where
        setting :: String -> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
        setting :: forall flag.
[Char]
-> [Char] -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting [Char]
prefix [Char]
noPrefix flag -> DynFlags -> Bool
test FlagSpec flag
flag
          | Bool
quiet     = SDoc
forall doc. IsOutput doc => doc
empty
          | Bool
is_on     = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
prefix SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
name
          | Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
noPrefix SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
name
          where name :: [Char]
name = FlagSpec flag -> [Char]
forall flag. FlagSpec flag -> [Char]
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 -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings 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 a. Eq a => a -> [a] -> 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 :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
setArgs [[Char]]
args = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  ForeignHValue
wrapper <- [Char] -> [[Char]] -> m ForeignHValue
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> [[Char]] -> m ForeignHValue
mkEvalWrapper (GHCiState -> [Char]
progname GHCiState
st) [[Char]]
args
  GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st { GhciMonad.args = args, evalWrapper = wrapper }

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

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

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

setStop :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
setStop str :: [Char]
str@(Char
c:[Char]
_) | Char -> Bool
isDigit Char
c
  = do let ([Char]
nm_str,[Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
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) [Char]
str
           nm :: Int
nm = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
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 ->  SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Breakpoint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                   [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"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 = dropWhile isSpace rest }
                                IntMap BreakLocation
old_breaks
            GHCiState -> m ()
forall (m :: Type -> Type). GhciMonad m => GHCiState -> m ()
setGHCiState GHCiState
st{ breaks = new_breaks }
setStop [Char]
cmd = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st { stop = cmd })

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

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

setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()
setPromptFunc :: forall (m :: Type -> Type).
GhcMonad m =>
(PromptFunction -> m ()) -> [Char] -> m ()
setPromptFunc PromptFunction -> m ()
fSetPrompt [Char]
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 :: [Char]
exprStr = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") :: [String] -> Int -> IO String"
    (HValue Any
funValue) <- [Char] -> m HValue
forall (m :: Type -> Type). GhcMonad m => [Char] -> m HValue
GHC.compileExpr [Char]
exprStr
    PromptFunction -> m ()
fSetPrompt (([[Char]] -> Int -> IO [Char]) -> PromptFunction
convertToPromptFunction (([[Char]] -> Int -> IO [Char]) -> PromptFunction)
-> ([[Char]] -> Int -> IO [Char]) -> PromptFunction
forall a b. (a -> b) -> a -> b
$ Any -> [[Char]] -> Int -> IO [Char]
forall a b. a -> b
unsafeCoerce Any
funValue)
    where
      convertToPromptFunction :: ([String] -> Int -> IO String)
                              -> PromptFunction
      convertToPromptFunction :: ([[Char]] -> Int -> IO [Char]) -> PromptFunction
convertToPromptFunction [[Char]] -> Int -> IO [Char]
func = (\[[Char]]
mods Int
line -> IO SDoc -> GHCi SDoc
forall a. IO a -> GHCi a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO SDoc -> GHCi SDoc) -> IO SDoc -> GHCi SDoc
forall a b. (a -> b) -> a -> b
$
                                       ([Char] -> SDoc) -> IO [Char] -> IO SDoc
forall (m :: Type -> Type) a1 r.
Monad m =>
(a1 -> r) -> m a1 -> m r
liftM [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([[Char]] -> Int -> IO [Char]
func [[Char]]
mods Int
line))

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

setParsedPromptString :: MonadIO m
                      => (PromptFunction -> m ()) ->  String -> m ()
setParsedPromptString :: forall (m :: Type -> Type).
MonadIO m =>
(PromptFunction -> m ()) -> [Char] -> m ()
setParsedPromptString PromptFunction -> m ()
fSetPrompt [Char]
s = do
  case ([Char] -> Maybe [Char]
checkPromptStringForErrors [Char]
s) of
    Just [Char]
err ->
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
err
    Maybe [Char]
Nothing ->
      PromptFunction -> m ()
fSetPrompt (PromptFunction -> m ()) -> PromptFunction -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PromptFunction
generatePromptFunctionFromString [Char]
s

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

-- | newDynFlags will *not* read package environment files, therefore we
-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
-- function is called very often and results in repeatedly loading
-- environment files (see #19650)
newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
newDynFlags :: forall (m :: Type -> Type). GhciMonad m => Bool -> [[Char]] -> m ()
newDynFlags Bool
interactive_only [[Char]]
minus_opts = do
      let lopts :: [Located [Char]]
lopts = ([Char] -> Located [Char]) -> [[Char]] -> [Located [Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Located [Char]
forall e. e -> Located e
noLoc [[Char]]
minus_opts

      Logger
logger <- m Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
      DynFlags
idflags0 <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags
      (DynFlags
idflags1, [Located [Char]]
leftovers, [Warn]
warns) <- DynFlags
-> [Located [Char]] -> m (DynFlags, [Located [Char]], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located [Char]] -> m (DynFlags, [Located [Char]], [Warn])
DynFlags.parseDynamicFlagsCmdLine DynFlags
idflags0 [Located [Char]]
lopts

      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
idflags1) (DynFlags -> DiagOpts
initDiagOpts 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 [Char]] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Located [Char]]
leftovers)
           (GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ())
-> ([Char] -> GhcException) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> GhcException
CmdLineError
            ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Some flags have not been recognized: "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Located [Char] -> [Char]) -> [Located [Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Located [Char] -> [Char]
forall l e. GenLocated l e -> e
unLoc [Located [Char]]
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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"cannot set package flags with :seti; use :set"
      DynFlags -> m ()
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m ()
GHC.setInteractiveDynFlags DynFlags
idflags1
      Maybe [Char] -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Maybe [Char] -> Bool -> m ()
installInteractivePrint (DynFlags -> Maybe [Char]
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 [Char]]
_, [Warn]
_) <- IO (DynFlags, [Located [Char]], [Warn])
-> m (DynFlags, [Located [Char]], [Warn])
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located [Char]], [Warn])
 -> m (DynFlags, [Located [Char]], [Warn]))
-> IO (DynFlags, [Located [Char]], [Warn])
-> m (DynFlags, [Located [Char]], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located [Char]] -> IO (DynFlags, [Located [Char]], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located [Char]] -> m (DynFlags, [Located [Char]], [Warn])
DynFlags.parseDynamicFlagsCmdLine DynFlags
dflags0 [Located [Char]]
lopts
        Bool
must_reload <- DynFlags -> m Bool
forall (m :: Type -> Type). GhcMonad m => DynFlags -> m Bool
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
        let interp :: Interp
interp  = HscEnv -> Interp
hscInterp 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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Char] -> IO ()) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
              [Char]
"package flags have changed, resetting and loading new packages..."
          -- Clear caches and eventually defined breakpoints. (#1620)
          m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearCaches
          Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
must_reload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let units :: [UnitId]
units = UnitState -> [UnitId]
preloadUnits ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [UnitId] -> IO ()
Loader.loadPackages Interp
interp HscEnv
hsc_env [UnitId]
units
          -- package flags changed, we can't re-use any of the old context
          Bool -> Maybe ModuleGraph -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
Bool -> Maybe ModuleGraph -> m ()
setContextAfterLoad Bool
False Maybe ModuleGraph
forall a. Maybe a
Nothing
          -- and copy the package flags 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{ packageFlags = packageFlags dflags2 }

        let ld0length :: Int
ld0length   = [Option] -> Int
forall a. [a] -> 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 = [[Char]] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([[Char]] -> Int) -> [[Char]] -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> [[Char]]
cmdlineFrameworks DynFlags
dflags0

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

            dflags' :: DynFlags
dflags'  = DynFlags
dflags2 { ldInputs = newLdInputs
                               , cmdlineFrameworks = newCLFrameworks
                               }
            hsc_env' :: HscEnv
hsc_env' = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags' HscEnv
hsc_env

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

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


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

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

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

     in case [[Char]]
rest3 of
          [Char]
opt:[[Char]]
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn ([Char]
"unknown option: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"))
          [] -> do
             ([Char] -> m ()) -> [[Char]] -> 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 ())
-> ([Char] -> Maybe (m ())) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Char] -> [([Char], m ())] -> Maybe (m ()))
-> [([Char], m ())] -> [Char] -> Maybe (m ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [([Char], m ())] -> Maybe (m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [([Char], m ())]
defaulters) [[Char]]
other_opts

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

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

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

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

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

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

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

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

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


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

showCmd :: forall m. GhciMonad m => String -> m ()
showCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
showCmd [Char]
""   = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
False
showCmd [Char]
"-a" = Bool -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> m ()
showOptions Bool
True
showCmd [Char]
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 :: [Char] -> Maybe (m ())
lookupCmd [Char]
name = [Char] -> [([Char], m ())] -> Maybe (m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name ([([Char], m ())] -> Maybe (m ()))
-> [([Char], m ())] -> Maybe (m ())
forall a b. (a -> b) -> a -> b
$ ((Bool, [Char], m ()) -> ([Char], m ()))
-> [(Bool, [Char], m ())] -> [([Char], m ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_,[Char]
b,m ()
c) -> ([Char]
b,m ()
c)) [(Bool, [Char], m ())]
cmds

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

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

        cmds :: [(Bool, [Char], m ())]
cmds =
            [ [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"args"       (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([[Char]] -> [Char]
forall a. Show a => a -> [Char]
show (GHCiState -> [[Char]]
GhciMonad.args GHCiState
st))
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"prog"       (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> [Char]
forall a. Show a => a -> [Char]
show (GHCiState -> [Char]
progname GHCiState
st))
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"editor"     (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> [Char]
forall a. Show a => a -> [Char]
show (GHCiState -> [Char]
editor GHCiState
st))
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"stop"       (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> [Char]
forall a. Show a => a -> [Char]
show (GHCiState -> [Char]
stop GHCiState
st))
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"imports"    (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhciMonad m => m ()
showImports
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"modules"    (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showModules
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"bindings"   (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showBindings
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"linker"     (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ do
               SDoc
msg <- IO SDoc -> m SDoc
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO SDoc -> m SDoc) -> IO SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ Interp -> IO SDoc
Loader.showLoaderState (HscEnv -> Interp
hscInterp HscEnv
hsc_env)
               DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
               IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags SDoc
msg
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"breaks"     (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhciMonad m => m ()
showBkptTable
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"context"    (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showContext
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"packages"   (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showUnits
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"paths"      (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showPaths
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"language"   (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages
            , [Char] -> m () -> (Bool, [Char], m ())
hidden [Char]
"languages"  (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages -- backwards compat
            , [Char] -> m () -> (Bool, [Char], m ())
hidden [Char]
"lang"       (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages -- useful abbreviation
            , [Char] -> m () -> (Bool, [Char], m ())
action [Char]
"targets"    (m () -> (Bool, [Char], m ())) -> m () -> (Bool, [Char], m ())
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: Type -> Type). GhcMonad m => m ()
showTargets
            ]

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

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

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

showImports :: GhciMonad m => m ()
showImports :: forall (m :: Type -> Type). GhciMonad m => 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 -> [Char]
show_one (IIModule ModuleName
star_m)
          = [Char]
":module +*" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString ModuleName
star_m
      show_one (IIDecl ImportDecl GhcPs
imp) = DynFlags -> ImportDecl GhcPs -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
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 -> [Char]
show_prel InteractiveImport
p = InteractiveImport -> [Char]
show_one InteractiveImport
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -- implicit"
      show_extra :: ImportDecl GhcPs -> [Char]
show_extra ImportDecl GhcPs
p = InteractiveImport -> [Char]
show_one (ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -- fixed"

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

showModules :: GHC.GhcMonad m => m ()
showModules :: forall (m :: Type -> Type). GhcMonad m => 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 [Char]
m <- ModSummary -> m [Char]
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m [Char]
GHC.showModule ModSummary
ms; IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn [Char]
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 :: forall (m :: Type -> Type). GhcMonad m => 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 ModSummary -> m Bool
forall (m :: Type -> Type). GhcMonad m => ModSummary -> m Bool
isLoadedModSummary (ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph)

showBindings :: GHC.GhcMonad m => m ()
showBindings :: forall (m :: Type -> Type). GhcMonad m => 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 :: [SDoc]
idocs  = (ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
GHC.pprInstanceHdr [ClsInst]
insts
        fidocs :: [SDoc]
fidocs = (FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
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]
    [SDoc]
docs <- (TyThing -> m SDoc) -> [TyThing] -> m [SDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM TyThing -> m SDoc
forall {m :: Type -> Type}. GhcMonad m => TyThing -> m SDoc
makeDoc ([TyThing] -> [TyThing]
forall a. [a] -> [a]
reverse [TyThing]
binds)
                  -- reverse so the new ones come last
    (SDoc -> m ()) -> [SDoc] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUserPartWay ([SDoc]
docs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
idocs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
fidocs)
  where
    makeDoc :: TyThing -> m SDoc
makeDoc (AnId Id
i) = Id -> m SDoc
forall (m :: Type -> Type). GhcMonad m => Id -> m SDoc
pprTypeAndContents Id
i
    makeDoc TyThing
tt = do
        Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff <- Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall (m :: Type -> Type).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
GHC.getInfo Bool
False (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tt)
        SDoc -> m SDoc
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SDoc -> m SDoc) -> SDoc -> m SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
-> ((TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc)
-> Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
-> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"") (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc
pprTT Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)
mb_stuff

    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
    pprTT :: (TyThing, Fixity, [ClsInst], [FamInst], SDoc) -> SDoc
pprTT (TyThing
thing, Fixity
fixity, [ClsInst]
_cls_insts, [FamInst]
_fam_insts, SDoc
_docs)
      = ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader TyThing
thing
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TyThing -> Fixity -> SDoc
showFixity TyThing
thing Fixity
fixity


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

isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool
isLoadedModSummary :: forall (m :: Type -> Type). GhcMonad m => ModSummary -> m Bool
isLoadedModSummary ModSummary
ms = UnitId -> ModuleName -> m Bool
forall (m :: Type -> Type).
GhcMonad m =>
UnitId -> ModuleName -> m Bool
GHC.isLoadedModule (ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModSummary -> ModuleName
ms_mod_name ModSummary
ms)

{-
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.Unit.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 GHC.Runtime.Eval

[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 :: forall (m :: Type -> Type). GhciMonad m => m ()
showBkptTable = do
  GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ IntMap BreakLocation -> SDoc
prettyLocations (GHCiState -> IntMap BreakLocation
breaks GHCiState
st)

showContext :: GHC.GhcMonad m => m ()
showContext :: forall (m :: Type -> Type). GhcMonad m => m ()
showContext = do
   [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
   SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Resume -> SDoc) -> [Resume] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Resume -> SDoc
pp_resume ([Resume] -> [Resume]
forall a. [a] -> [a]
reverse [Resume]
resumes))
  where
   pp_resume :: Resume -> SDoc
pp_resume Resume
res =
        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"--> " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Resume -> [Char]
GHC.resumeStmt Resume
res)
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (Resume -> SDoc
pprStopped Resume
res)

pprStopped :: GHC.Resume -> SDoc
pprStopped :: Resume -> SDoc
pprStopped Resume
res =
  [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Stopped in"
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ((case Maybe ModuleName
mb_mod_name of
           Maybe ModuleName
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
           Just ModuleName
mod_name -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (ModuleName -> FastString
moduleNameFS ModuleName
mod_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'.')
         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Resume -> [Char]
GHC.resumeDecl Resume
res))
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
',' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Resume -> SrcSpan
GHC.resumeSpan Resume
res)
 where
  mb_mod_name :: Maybe ModuleName
mb_mod_name = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName)
-> (BreakInfo -> GenModule Unit) -> BreakInfo -> ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> BreakInfo -> GenModule Unit
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

showUnits :: GHC.GhcMonad m => m ()
showUnits :: forall (m :: Type -> Type). GhcMonad m => m ()
showUnits = 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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$
    [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"active package flags:"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++if [PackageFlag] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [PackageFlag]
pkg_flags then [Char]
" none" else [Char]
"") SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((PackageFlag -> SDoc) -> [PackageFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> SDoc
pprFlag [PackageFlag]
pkg_flags))

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

showLanguages :: GHC.GhcMonad m => m ()
showLanguages :: forall (m :: Type -> Type). GhcMonad m => m ()
showLanguages = m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall a. IO a -> m a
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 :: forall (m :: Type -> Type). GhcMonad m => m ()
showiLanguages = m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags m DynFlags -> (DynFlags -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> m ()
forall a. IO a -> m a
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 =
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
     [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"base language is: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
         case Language
lang of
           Language
Haskell98   -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Haskell98"
           Language
Haskell2010 -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Haskell2010"
           Language
GHC2021     -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"GHC2021"
     , (if Bool
show_all then [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"all active language options:"
                    else [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"with the following modifiers:") SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
          Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FlagSpec Extension -> SDoc) -> [FlagSpec Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((Extension -> DynFlags -> Bool) -> FlagSpec Extension -> SDoc
setting Extension -> DynFlags -> Bool
xopt) [FlagSpec Extension]
DynFlags.xFlags))
     ]
  where
   setting :: (Extension -> DynFlags -> Bool) -> FlagSpec Extension -> SDoc
setting Extension -> DynFlags -> Bool
test FlagSpec Extension
flag
          | Bool
quiet     = SDoc
forall doc. IsOutput doc => doc
empty
          | Bool
is_on     = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"-X" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
name
          | Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"-XNo" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
name
          where name :: [Char]
name = FlagSpec Extension -> [Char]
forall flag. FlagSpec flag -> [Char]
flagSpecName FlagSpec Extension
flag
                f :: Extension
f = FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
flag
                is_on :: Bool
is_on = Extension -> DynFlags -> Bool
test Extension
f DynFlags
dflags
                quiet :: Bool
quiet = Bool -> Bool
not Bool
show_all Bool -> Bool -> Bool
&& Extension -> DynFlags -> Bool
test Extension
f DynFlags
default_dflags Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
is_on

   default_dflags :: DynFlags
default_dflags = Settings -> DynFlags
defaultDynFlags (DynFlags -> Settings
settings DynFlags
dflags) DynFlags -> Maybe Language -> DynFlags
`lang_set` Language -> Maybe Language
forall a. a -> Maybe a
Just Language
lang

   lang :: Language
lang = Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe Language
GHC2021 (DynFlags -> Maybe Language
language DynFlags
dflags)


showTargets :: GHC.GhcMonad m => m ()
showTargets :: forall (m :: Type -> Type). GhcMonad m => 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 :: forall (m :: Type -> Type). GhcMonad m => Target -> m ()
showTarget Target { targetId :: Target -> TargetId
targetId = TargetFile [Char]
f Maybe Phase
_ } = IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn [Char]
f)
    showTarget Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
m } =
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
m)

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

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

    breakSpace :: [Char] -> ([Char], [Char])
breakSpace = ([Char] -> [Char]) -> ([Char], [Char]) -> ([Char], [Char])
forall a b. (a -> b) -> ([Char], a) -> ([Char], b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace) (([Char], [Char]) -> ([Char], [Char]))
-> ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> ([Char], [Char])
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 :: [Char] -> Maybe (Maybe Int, Maybe Int)
parseRange [Char]
s = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
s of
                   ([Char]
_, [Char]
"") ->
                       -- 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, [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
bndRead [Char]
s)
                   ([Char]
s1, Char
'-' : [Char]
s2)
                    | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
s2 ->
                       (Maybe Int, Maybe Int) -> Maybe (Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just ([Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
bndRead [Char]
s1, [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
bndRead [Char]
s2)
                   ([Char], [Char])
_ ->
                       Maybe (Maybe Int, Maybe Int)
forall a. Maybe a
Nothing
      where
        bndRead :: [Char] -> Maybe a
bndRead [Char]
x = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
x then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just ([Char] -> a
forall a. Read a => [Char] -> a
read [Char]
x)



completeGhciCommand, completeMacro, completeIdentifier, completeModule,
    completeSetModule, completeSeti, completeShowiOptions,
    completeHomeModule, completeSetOptions, completeShowOptions,
    completeHomeModuleOrFile, completeExpression, completeBreakpoint
    :: 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 :: ([Char], [Char])
line@([Char]
left,[Char]
_) = case [Char]
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
':':[Char]
cmd     | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
rest     -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeGhciCommand ([Char], [Char])
line
                | Bool
otherwise     -> do
                        CompletionFunc GHCi
completion <- [Char] -> GHCi (CompletionFunc GHCi)
forall {m :: Type -> Type}.
GhciMonad m =>
[Char] -> m (CompletionFunc GHCi)
lookupCompletion [Char]
cmd
                        CompletionFunc GHCi
completion ([Char], [Char])
line
    -- If given string starts with `import` keyword provide module name
    -- completions
    [Char]
"import"    -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule ([Char], [Char])
line
    -- otherwise provide identifier completions
    [Char]
_           -> CompletionFunc GHCi
forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeExpression ([Char], [Char])
line
  where
    ([Char]
firstWord,[Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
left
    lookupCompletion :: [Char] -> m (CompletionFunc GHCi)
lookupCompletion (Char
'!':[Char]
_) = CompletionFunc GHCi -> m (CompletionFunc GHCi)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename
    lookupCompletion [Char]
c = do
        Maybe Command
maybe_cmd <- [Char] -> m (Maybe Command)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe Command)
lookupCommand' [Char]
c
        case Maybe Command
maybe_cmd of
            Just Command
cmd -> CompletionFunc GHCi -> m (CompletionFunc GHCi)
forall a. a -> m a
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompletionFunc GHCi
forall (m :: Type -> Type). MonadIO m => CompletionFunc m
completeFilename

completeGhciCommand :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeGhciCommand = [Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
[Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter [Char]
" " (([Char] -> m [[Char]]) -> CompletionFunc m)
-> ([Char] -> m [[Char]]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \[Char]
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 a b. (a -> b) -> m a -> m b
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 :: [[Char]]
macro_names = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([[Char]] -> [[Char]])
-> ([Command] -> [[Char]]) -> [Command] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
cmdName ([Command] -> [[Char]]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Command]
macros
  let command_names :: [[Char]]
command_names = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([[Char]] -> [[Char]])
-> ([Command] -> [[Char]]) -> [Command] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
cmdName ([Command] -> [[Char]]) -> [Command] -> [[Char]]
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 :: [[Char]]
candidates = case [Char]
w of
      Char
':' : Char
':' : [Char]
_ -> ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) [[Char]]
command_names
      [Char]
_ -> [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
macro_names [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
command_names }
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
`isPrefixOptOf`) [[Char]]
candidates

completeMacro :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeMacro = ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleter (([Char] -> m [[Char]]) -> CompletionFunc m)
-> ([Char] -> m [[Char]]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \[Char]
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
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ((Command -> [Char]) -> [Command] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command -> [Char]
cmdName [Command]
cmds))

completeIdentifier :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeIdentifier line :: ([Char], [Char])
line@([Char]
left, [Char]
_) =
  -- Note: `left` is a reversed input
  case [Char]
left of
    (Char
'.':[Char]
_)  -> [Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
[Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter ([Char]
specials [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
spaces) [Char] -> m [[Char]]
forall {m :: Type -> Type}. GhcMonad m => [Char] -> m [[Char]]
complete ([Char], [Char])
line
               -- operator or qualification
    (Char
x:[Char]
_) | Char -> Bool
isSymbolChar Char
x -> (Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter' (\Char
c -> Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ([Char]
specials [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
spaces) Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isSymbolChar Char
c))
                                 [Char] -> m [[Char]]
forall {m :: Type -> Type}. GhcMonad m => [Char] -> m [[Char]]
complete ([Char], [Char])
line         -- operator
    [Char]
_                      -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleter [Char] -> m [[Char]]
forall {m :: Type -> Type}. GhcMonad m => [Char] -> m [[Char]]
complete ([Char], [Char])
line
  where
    complete :: [Char] -> m [[Char]]
complete [Char]
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
      [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ((RdrName -> [Char]) -> [RdrName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> RdrName -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
dflags) [RdrName]
rdrs))

-- TAB-completion for the :break command.
-- Build and return a list of breakpoint identifiers with a given prefix.
-- See Note [Tab-completion for :break]
completeBreakpoint :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeBreakpoint = [Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
[Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter [Char]
spaces (([Char] -> m [[Char]]) -> CompletionFunc m)
-> ([Char] -> m [[Char]]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \[Char]
w -> do          -- #3000
    -- bid ~ breakpoint identifier = a name of a function that is
    --       eligible to set a breakpoint.
    let ([Char]
mod_str, [Char]
_, [Char]
_) = [Char] -> ([Char], [Char], [Char])
splitIdent [Char]
w
    [[Char]]
bids_mod_breaks <- [Char] -> m [[Char]]
forall (m :: Type -> Type). GhciMonad m => [Char] -> m [[Char]]
bidsFromModBreaks [Char]
mod_str
    [[Char]]
bids_inscopes <- m [[Char]]
forall (m :: Type -> Type). GhciMonad m => m [[Char]]
bidsFromInscopes
    [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
w) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
bids_mod_breaks [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
bids_inscopes
  where
    -- Extract all bids from ModBreaks for a given module name prefix
    bidsFromModBreaks :: GhciMonad m => String -> m [String]
    bidsFromModBreaks :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m [[Char]]
bidsFromModBreaks [Char]
mod_pref = do
        [GenModule Unit]
imods <- m [GenModule Unit]
forall (m :: Type -> Type). GhciMonad m => m [GenModule Unit]
interpretedHomeMods
        let pmods :: [GenModule Unit]
pmods = (GenModule Unit -> Bool) -> [GenModule Unit] -> [GenModule Unit]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
mod_pref) ([Char] -> Bool)
-> (GenModule Unit -> [Char]) -> GenModule Unit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> [Char]
showModule) [GenModule Unit]
imods
        [ModuleName]
nonquals <- case [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
mod_pref of
          -- If the prefix is empty, then for functions declared in a module
          -- in scope, don't qualify the function name.
          -- (eg: `main` instead of `Main.main`)
            Bool
True -> do
                [InteractiveImport]
imports <- m [InteractiveImport]
forall (m :: Type -> Type). GhcMonad m => m [InteractiveImport]
GHC.getContext
                [ModuleName] -> m [ModuleName]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [ ModuleName
m | IIModule ModuleName
m <- [InteractiveImport]
imports]
            Bool
False -> [ModuleName] -> m [ModuleName]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
        [[[Char]]]
bidss <- (GenModule Unit -> m [[Char]]) -> [GenModule Unit] -> m [[[Char]]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ([ModuleName] -> GenModule Unit -> m [[Char]]
forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> GenModule Unit -> m [[Char]]
bidsByModule [ModuleName]
nonquals) [GenModule Unit]
pmods
        [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
bidss

    -- Return a list of interpreted home modules
    interpretedHomeMods :: GhciMonad m => m [Module]
    interpretedHomeMods :: forall (m :: Type -> Type). GhciMonad m => m [GenModule Unit]
interpretedHomeMods = do
        ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
        let hmods :: [GenModule Unit]
hmods = ModSummary -> GenModule Unit
ms_mod (ModSummary -> GenModule Unit) -> [ModSummary] -> [GenModule Unit]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph
        (GenModule Unit -> m Bool)
-> [GenModule Unit] -> m [GenModule Unit]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.moduleIsInterpreted [GenModule Unit]
hmods

    -- Return all possible bids for a given Module
    bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
    bidsByModule :: forall (m :: Type -> Type).
GhciMonad m =>
[ModuleName] -> GenModule Unit -> m [[Char]]
bidsByModule [ModuleName]
nonquals GenModule Unit
mod = do
      (Array Int SrcSpan
_, Array Int [[Char]]
decls) <- GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
getModBreak GenModule Unit
mod
      let bids :: [[Char]]
bids = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
declPath ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Array Int [[Char]] -> [[[Char]]]
forall i e. Array i e -> [e]
elems Array Int [[Char]]
decls
      [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ case (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
mod) ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ModuleName]
nonquals of
              Bool
True  -> [[Char]]
bids
              Bool
False -> ([Char] -> [Char] -> [Char]
combineModIdent (GenModule Unit -> [Char]
showModule GenModule Unit
mod)) ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
bids

    -- Extract all bids from all top-level identifiers in scope.
    bidsFromInscopes :: GhciMonad m => m [String]
    bidsFromInscopes :: forall (m :: Type -> Type). GhciMonad m => m [[Char]]
bidsFromInscopes = do
        DynFlags
dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
        [RdrName]
rdrs <- m [RdrName]
forall (m :: Type -> Type). GhcMonad m => m [RdrName]
GHC.getRdrNamesInScope
        [[([Char], GenModule Unit)]]
inscopess <- ([Char] -> m [([Char], GenModule Unit)])
-> [[Char]] -> m [[([Char], GenModule Unit)]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM [Char] -> m [([Char], GenModule Unit)]
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m [([Char], GenModule Unit)]
createInscope ([[Char]] -> m [[([Char], GenModule Unit)]])
-> [[Char]] -> m [[([Char], GenModule Unit)]]
forall a b. (a -> b) -> a -> b
$ (DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> (RdrName -> SDoc) -> RdrName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr) (RdrName -> [Char]) -> [RdrName] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RdrName]
rdrs
        [GenModule Unit]
imods <- m [GenModule Unit]
forall (m :: Type -> Type). GhciMonad m => m [GenModule Unit]
interpretedHomeMods
        let topLevels :: [([Char], GenModule Unit)]
topLevels = (([Char], GenModule Unit) -> Bool)
-> [([Char], GenModule Unit)] -> [([Char], GenModule Unit)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GenModule Unit -> [GenModule Unit] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [GenModule Unit]
imods) (GenModule Unit -> Bool)
-> (([Char], GenModule Unit) -> GenModule Unit)
-> ([Char], GenModule Unit)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], GenModule Unit) -> GenModule Unit
forall a b. (a, b) -> b
snd) ([([Char], GenModule Unit)] -> [([Char], GenModule Unit)])
-> [([Char], GenModule Unit)] -> [([Char], GenModule Unit)]
forall a b. (a -> b) -> a -> b
$ [[([Char], GenModule Unit)]] -> [([Char], GenModule Unit)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[([Char], GenModule Unit)]]
inscopess
        [[[Char]]]
bidss <- (([Char], GenModule Unit) -> m [[Char]])
-> [([Char], GenModule Unit)] -> m [[[Char]]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (([Char], GenModule Unit) -> m [[Char]]
forall (m :: Type -> Type).
GhciMonad m =>
([Char], GenModule Unit) -> m [[Char]]
addNestedDecls) [([Char], GenModule Unit)]
topLevels
        [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
bidss

    -- Return a list of (bid,module) for a single top-level in-scope identifier
    createInscope :: GhciMonad m => String -> m [(String, Module)]
    createInscope :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m [([Char], GenModule Unit)]
createInscope [Char]
str_rdr = do
        NonEmpty Name
names <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
str_rdr
        [([Char], GenModule Unit)] -> m [([Char], GenModule Unit)]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([([Char], GenModule Unit)] -> m [([Char], GenModule Unit)])
-> [([Char], GenModule Unit)] -> m [([Char], GenModule Unit)]
forall a b. (a -> b) -> a -> b
$ (GenModule Unit -> ([Char], GenModule Unit))
-> [GenModule Unit] -> [([Char], GenModule Unit)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
str_rdr, ) ([GenModule Unit] -> [([Char], GenModule Unit)])
-> [GenModule Unit] -> [([Char], GenModule Unit)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenModule Unit) -> [GenModule Unit]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (GenModule Unit) -> [GenModule Unit])
-> NonEmpty (GenModule Unit) -> [GenModule Unit]
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
GHC.nameModule (Name -> GenModule Unit)
-> NonEmpty Name -> NonEmpty (GenModule Unit)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Name
names

    -- For every top-level identifier in scope, add the bids of the nested
    -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
    addNestedDecls :: GhciMonad m => (String, Module) -> m [String]
    addNestedDecls :: forall (m :: Type -> Type).
GhciMonad m =>
([Char], GenModule Unit) -> m [[Char]]
addNestedDecls ([Char]
ident, GenModule Unit
mod) = do
        (Array Int SrcSpan
_, Array Int [[Char]]
decls) <- GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
getModBreak GenModule Unit
mod
        let ([Char]
mod_str, [Char]
topLvl, [Char]
_) = [Char] -> ([Char], [Char], [Char])
splitIdent [Char]
ident
            ident_decls :: [[[Char]]]
ident_decls = [ [[Char]]
elm | elm :: [[Char]]
elm@([Char]
el : [[Char]]
_) <- Array Int [[Char]] -> [[[Char]]]
forall i e. Array i e -> [e]
elems Array Int [[Char]]
decls, [Char]
el [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
topLvl ]
            bids :: [[Char]]
bids = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
declPath ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[[Char]]]
ident_decls
        [[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
combineModIdent [Char]
mod_str) [[Char]]
bids

completeModule :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeModule = ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleterMod (([Char] -> m [[Char]]) -> CompletionFunc m)
-> ([Char] -> m [[Char]]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \[Char]
w -> do
  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  let pkg_mods :: [ModuleName]
pkg_mods = UnitState -> [ModuleName]
allVisibleModules ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
  [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
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
        ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) ([ModuleName] -> [[Char]]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
loaded_mods [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
pkg_mods

completeSetModule :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeSetModule = [Char] -> (Maybe Char -> [Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
[Char] -> (Maybe Char -> [Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleterWithModifier [Char]
"+-" ((Maybe Char -> [Char] -> m [[Char]]) -> CompletionFunc m)
-> (Maybe Char -> [Char] -> m [[Char]]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \Maybe Char
m [Char]
w -> do
  HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  [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 a. a -> m a
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 = UnitState -> [ModuleName]
allVisibleModules ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
      [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 a. a -> m a
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
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) [ModuleName]
modules

completeHomeModule :: forall (m :: Type -> Type). GhciMonad m => CompletionFunc m
completeHomeModule = ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleterMod [Char] -> m [[Char]]
forall {m :: Type -> Type}. GhcMonad m => [Char] -> m [[Char]]
listHomeModules

listHomeModules :: GHC.GhcMonad m => String -> m [String]
listHomeModules :: forall {m :: Type -> Type}. GhcMonad m => [Char] -> m [[Char]]
listHomeModules [Char]
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
    [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char]
w [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
            ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> ModuleName -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
dflags) [ModuleName]
home_mods

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

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

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

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

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

unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
unionComplete :: forall (m :: Type -> Type) a b.
Monad m =>
(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 a. a -> m a
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 :: forall (m :: Type -> Type).
Monad m =>
[Char] -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter [Char]
breakChars = (Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter' (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Char]
breakChars)

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

wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m
wrapIdentCompleter :: forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleter = (Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter' Char -> Bool
word_break_chars_pred

wrapIdentCompleterMod :: Monad m => (String -> m [String]) -> CompletionFunc m
wrapIdentCompleterMod :: forall (m :: Type -> Type).
Monad m =>
([Char] -> m [[Char]]) -> CompletionFunc m
wrapIdentCompleterMod = (Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
forall (m :: Type -> Type).
Monad m =>
(Char -> Bool) -> ([Char] -> m [[Char]]) -> CompletionFunc m
wrapCompleter' Char -> Bool
go
  where
    go :: Char -> Bool
go Char
'.' = Bool
False -- Treated specially since it is a seperator for module qualifiers
    go Char
c = Char -> Bool
word_break_chars_pred Char
c

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

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

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


{-
Note [Tab-completion for :break]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In tab-completion for the `:break` command, only those
identifiers should be shown, that are accepted in the
`:break` command. Hence these identifiers must be

- defined in an interpreted module
- listed in a `ModBreaks` value as a possible breakpoint.

The identifiers may be qualified or unqualified.

To get all possible top-level breakpoints for tab-completion
with the correct qualification do:

1. Build a list called `bids_mod_breaks` of identifier names eligible
for setting breakpoints: For every interpreted module with the
correct module prefix read all identifier names from the `decls` field
of the `ModBreaks` array.

2. Build a list called `bids_inscopess` of identifiers in scope:
Take all RdrNames in scope, and filter by interpreted modules.
Fore each of these top-level identifiers add from the `ModBreaks`
arrays the available identifiers of the nested functions.

3.) Combine both lists, filter by the given prefix, and remove duplicates.
-}

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

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

stepCmd :: GhciMonad m => String -> m ()
stepCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
stepCmd [Char]
arg = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":step" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
step [Char]
arg
  where
  step :: [Char] -> 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 [Char]
expression = [Char] -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> SingleStep -> m (Maybe ExecResult)
runStmt [Char]
expression SingleStep
GHC.SingleStep m (Maybe ExecResult) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

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

stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
stepModuleCmd [Char]
arg = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":stepmodule" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
step [Char]
arg
  where
  step :: [Char] -> m ()
step [Char]
expr
   | Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
expr) = [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
stepCmd [Char]
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  -> [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> 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 :: forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> SrcSpan -> m RealSrcSpan
enclosingTickSpan GenModule Unit
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = [Char] -> m RealSrcSpan
forall a. HasCallStack => [Char] -> a
panic [Char]
"enclosingTickSpan UnhelpfulSpan"
enclosingTickSpan GenModule Unit
md (RealSrcSpan RealSrcSpan
src Maybe BufSpan
_) = do
  TickArray
ticks <- GenModule Unit -> m TickArray
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> m TickArray
getTickArray GenModule Unit
md
  let line :: Int
line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
src
  Bool -> m ()
forall (m :: Type -> Type).
(HasCallStack, Applicative m) =>
Bool -> m ()
massert ((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
ticks) Int
line)
  let enclosing_spans :: [RealSrcSpan]
enclosing_spans = [ RealSrcSpan
pan | (Int
_,RealSrcSpan
pan) <- TickArray
ticks TickArray -> Int -> [(Int, RealSrcSpan)]
forall i e. Ix i => Array i e -> i -> e
! Int
line
                               , RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
pan RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
src]
  RealSrcSpan -> m RealSrcSpan
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RealSrcSpan -> m RealSrcSpan)
-> ([RealSrcSpan] -> RealSrcSpan) -> [RealSrcSpan] -> m RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan -> RealSrcSpan -> Ordering)
-> [RealSrcSpan] -> RealSrcSpan
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan ([RealSrcSpan] -> m RealSrcSpan) -> [RealSrcSpan] -> m RealSrcSpan
forall a b. (a -> b) -> a -> b
$ [RealSrcSpan]
enclosing_spans
 where

leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
leftmostLargestRealSrcSpan = (RealSrcLoc -> RealSrcLoc -> Ordering)
-> (RealSrcSpan -> RealSrcLoc)
-> RealSrcSpan
-> RealSrcSpan
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on RealSrcLoc -> RealSrcLoc -> Ordering
forall a. Ord a => a -> a -> Ordering
compare RealSrcSpan -> RealSrcLoc
realSrcSpanStart (RealSrcSpan -> RealSrcSpan -> Ordering)
-> (RealSrcSpan -> RealSrcSpan -> Ordering)
-> RealSrcSpan
-> RealSrcSpan
-> Ordering
forall a. Semigroup a => a -> a -> a
S.<> (RealSrcLoc -> RealSrcLoc -> Ordering)
-> (RealSrcSpan -> RealSrcLoc)
-> RealSrcSpan
-> RealSrcSpan
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on ((RealSrcLoc -> RealSrcLoc -> Ordering)
-> RealSrcLoc -> RealSrcLoc -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcLoc -> RealSrcLoc -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) RealSrcSpan -> RealSrcLoc
realSrcSpanEnd

traceCmd :: GhciMonad m => String -> m ()
traceCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
traceCmd [Char]
arg
  = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":trace" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
tr [Char]
arg
  where
  tr :: [Char] -> 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 [Char]
expression = [Char] -> SingleStep -> m (Maybe ExecResult)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> SingleStep -> m (Maybe ExecResult)
runStmt [Char]
expression SingleStep
GHC.RunAndLogSteps m (Maybe ExecResult) -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

continueCmd :: GhciMonad m => String -> m ()                  -- #19157
continueCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
continueCmd [Char]
argLine = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":continue" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
  case [[Char]] -> Either SDoc (Maybe Int)
contSwitch ([Char] -> [[Char]]
words [Char]
argLine) of
    Left SDoc
sdoc   -> SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser SDoc
sdoc
    Right Maybe Int
mbCnt -> (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
doContinue' (Bool -> SrcSpan -> Bool
forall a b. a -> b -> a
const Bool
True) SingleStep
GHC.RunToCompletion Maybe Int
mbCnt
    where
      contSwitch :: [String] -> Either SDoc (Maybe Int)
      contSwitch :: [[Char]] -> Either SDoc (Maybe Int)
contSwitch [ ] = Maybe Int -> Either SDoc (Maybe Int)
forall a b. b -> Either a b
Right Maybe Int
forall a. Maybe a
Nothing
      contSwitch [[Char]
x] = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Either SDoc Int -> Either SDoc (Maybe Int)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either SDoc Int
getIgnoreCount [Char]
x
      contSwitch  [[Char]]
_  = SDoc -> Either SDoc (Maybe Int)
forall a b. a -> Either a b
Left (SDoc -> Either SDoc (Maybe Int))
-> SDoc -> Either SDoc (Maybe Int)
forall a b. (a -> b) -> a -> b
$
          [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"After ':continue' only one ignore count is allowed"

doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
doContinue :: forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> m ()
doContinue SrcSpan -> Bool
pre SingleStep
step = (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
doContinue' SrcSpan -> Bool
pre SingleStep
step Maybe Int
forall a. Maybe a
Nothing

doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
doContinue' :: forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()
doContinue' SrcSpan -> Bool
pre SingleStep
step Maybe Int
mbCnt= do
  ExecResult
runResult <- (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult
forall (m :: Type -> Type).
GhciMonad m =>
(SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult
resume SrcSpan -> Bool
pre SingleStep
step Maybe Int
mbCnt
  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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

abandonCmd :: GhciMonad m => String -> m ()
abandonCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
abandonCmd = m () -> [Char] -> m ()
forall (m :: Type -> Type). MonadIO m => m () -> [Char] -> m ()
noArgs (m () -> [Char] -> m ()) -> m () -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"There is no computation running."

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

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

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

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

checkEnaDisa :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)
checkEnaDisa :: forall (m :: Type -> Type).
GhciMonad m =>
Bool -> [Char] -> m (Either SDoc BreakLocation)
checkEnaDisa Bool
enaDisa [Char]
strId = do
    Either SDoc BreakLocation
sdoc_loc <- [Char] -> m (Either SDoc BreakLocation)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Either SDoc BreakLocation)
getBreakLoc [Char]
strId
    Either SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either SDoc BreakLocation -> m (Either SDoc BreakLocation))
-> Either SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ Either SDoc BreakLocation
sdoc_loc Either SDoc BreakLocation
-> (BreakLocation -> Either SDoc BreakLocation)
-> Either SDoc BreakLocation
forall a b. Either SDoc a -> (a -> Either SDoc b) -> Either SDoc b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> [Char] -> BreakLocation -> Either SDoc BreakLocation
checkEnaDisaState Bool
enaDisa [Char]
strId

getBreakLoc :: GhciMonad m => String -> m (Either SDoc BreakLocation)
getBreakLoc :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Either SDoc BreakLocation)
getBreakLoc [Char]
strId = do
    GHCiState
st <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
    case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
strId Maybe Int -> (Int -> Maybe BreakLocation) -> Maybe BreakLocation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either SDoc BreakLocation -> m (Either SDoc BreakLocation))
-> Either SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ SDoc -> Either SDoc BreakLocation
forall a b. a -> Either a b
Left ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Breakpoint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
strId SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not found")
      Just BreakLocation
loc -> Either SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either SDoc BreakLocation -> m (Either SDoc BreakLocation))
-> Either SDoc BreakLocation -> m (Either SDoc BreakLocation)
forall a b. (a -> b) -> a -> b
$ BreakLocation -> Either SDoc BreakLocation
forall a b. b -> Either a b
Right BreakLocation
loc

checkEnaDisaState :: Bool -> String -> BreakLocation -> Either SDoc BreakLocation
checkEnaDisaState :: Bool -> [Char] -> BreakLocation -> Either SDoc BreakLocation
checkEnaDisaState Bool
enaDisa [Char]
strId BreakLocation
loc = do
    if BreakLocation -> Bool
breakEnabled BreakLocation
loc Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
enaDisa
    then SDoc -> Either SDoc BreakLocation
forall a b. a -> Either a b
Left (SDoc -> Either SDoc BreakLocation)
-> SDoc -> Either SDoc BreakLocation
forall a b. (a -> b) -> a -> b
$
        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Breakpoint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
strId SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"already in desired state"
    else BreakLocation -> Either SDoc BreakLocation
forall a b. b -> Either a b
Right BreakLocation
loc

enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()
enaDisaAssoc :: forall (m :: Type -> Type).
GhciMonad m =>
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).
GhciMonad 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 = new_breaks }

enaDisaAllBreaks :: GhciMonad m => Bool -> m()
enaDisaAllBreaks :: forall (m :: Type -> Type). GhciMonad m => 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 :: forall (m :: Type -> Type). GhcMonad m => [Char] -> m ()
historyCmd [Char]
arg
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
arg        = Int -> m ()
forall {m :: Type -> Type}. GhcMonad m => Int -> m ()
history Int
20
  | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
arg = Int -> m ()
forall {m :: Type -> Type}. GhcMonad m => Int -> m ()
history ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg)
  | Bool
otherwise       = IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [Char]
"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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM History -> m SrcSpan
forall (m :: Type -> Type). GhcMonad m => History -> m SrcSpan
GHC.getHistorySpan [History]
took
                 let nums :: [[Char]]
nums  = (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"-%-3d:") [(Int
1::Int)..]
                     names :: [[[Char]]]
names = (History -> [[Char]]) -> [History] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map History -> [[Char]]
GHC.historyEnclosingDecls [History]
took
                 SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat((SDoc -> SDoc -> SDoc -> SDoc)
-> [SDoc] -> [SDoc] -> [SDoc] -> [SDoc]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
                                 (\SDoc
x SDoc
y SDoc
z -> SDoc
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
y SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
z)
                                 (([Char] -> SDoc) -> [[Char]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [[Char]]
nums)
                                 (([[Char]] -> SDoc) -> [[[Char]]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
bold (SDoc -> SDoc) -> ([[Char]] -> SDoc) -> [[Char]] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> ([[Char]] -> [SDoc]) -> [[Char]] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
colon ([SDoc] -> [SDoc]) -> ([[Char]] -> [SDoc]) -> [[Char]] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> SDoc) -> [[Char]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text) [[[Char]]]
names)
                                 ((SrcSpan -> SDoc) -> [SrcSpan] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [SrcSpan]
pans)))
                 IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ if [History] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [History]
rest then [Char]
"<end of history>" else [Char]
"..."

bold :: SDoc -> SDoc
bold :: SDoc -> SDoc
bold SDoc
c | Bool
do_bold   = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
start_bold SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
end_bold
       | Bool
otherwise = SDoc
c

ignoreCmd  :: GhciMonad m => String -> m ()                     -- #19157
ignoreCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
ignoreCmd [Char]
argLine = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":ignore" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Either SDoc (BreakLocation, Int)
result <- [[Char]] -> m (Either SDoc (BreakLocation, Int))
forall (m :: Type -> Type).
GhciMonad m =>
[[Char]] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch ([Char] -> [[Char]]
words [Char]
argLine)
    case Either SDoc (BreakLocation, Int)
result of
      Left SDoc
sdoc -> SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser SDoc
sdoc
      Right (BreakLocation
loc, Int
count)   -> do
        let breakInfo :: BreakInfo
breakInfo = GenModule Unit -> Int -> BreakInfo
GHC.BreakInfo (BreakLocation -> GenModule Unit
breakModule BreakLocation
loc) (BreakLocation -> Int
breakTick BreakLocation
loc)
        BreakInfo -> Int -> m ()
forall (m :: Type -> Type). GhciMonad m => BreakInfo -> Int -> m ()
setupBreakpoint BreakInfo
breakInfo Int
count

ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch :: forall (m :: Type -> Type).
GhciMonad m =>
[[Char]] -> m (Either SDoc (BreakLocation, Int))
ignoreSwitch [[Char]
break, [Char]
count] = do
    Either SDoc BreakLocation
sdoc_loc <- [Char] -> m (Either SDoc BreakLocation)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Either SDoc BreakLocation)
getBreakLoc [Char]
break
    Either SDoc (BreakLocation, Int)
-> m (Either SDoc (BreakLocation, Int))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either SDoc (BreakLocation, Int)
 -> m (Either SDoc (BreakLocation, Int)))
-> Either SDoc (BreakLocation, Int)
-> m (Either SDoc (BreakLocation, Int))
forall a b. (a -> b) -> a -> b
$ (,) (BreakLocation -> Int -> (BreakLocation, Int))
-> Either SDoc BreakLocation
-> Either SDoc (Int -> (BreakLocation, Int))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either SDoc BreakLocation
sdoc_loc Either SDoc (Int -> (BreakLocation, Int))
-> Either SDoc Int -> Either SDoc (BreakLocation, Int)
forall a b. Either SDoc (a -> b) -> Either SDoc a -> Either SDoc b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Char] -> Either SDoc Int
getIgnoreCount [Char]
count
ignoreSwitch [[Char]]
_ = Either SDoc (BreakLocation, Int)
-> m (Either SDoc (BreakLocation, Int))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either SDoc (BreakLocation, Int)
 -> m (Either SDoc (BreakLocation, Int)))
-> Either SDoc (BreakLocation, Int)
-> m (Either SDoc (BreakLocation, Int))
forall a b. (a -> b) -> a -> b
$ SDoc -> Either SDoc (BreakLocation, Int)
forall a b. a -> Either a b
Left (SDoc -> Either SDoc (BreakLocation, Int))
-> SDoc -> Either SDoc (BreakLocation, Int)
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Syntax:  :ignore <breaknum> <count>"

getIgnoreCount :: String -> Either SDoc Int
getIgnoreCount :: [Char] -> Either SDoc Int
getIgnoreCount [Char]
str =
    case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
str of
      Maybe Int
Nothing              -> SDoc -> Either SDoc Int
forall a b. a -> Either a b
Left (SDoc -> Either SDoc Int) -> SDoc -> Either SDoc Int
forall a b. (a -> b) -> a -> b
$ SDoc
sdocIgnore SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
"is not numeric"
      Just Int
cnt | Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0   -> SDoc -> Either SDoc Int
forall a b. a -> Either a b
Left (SDoc -> Either SDoc Int) -> SDoc -> Either SDoc Int
forall a b. (a -> b) -> a -> b
$ SDoc
sdocIgnore SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
"must be >= 0"
               | Bool
otherwise -> Int -> Either SDoc Int
forall a b. b -> Either a b
Right Int
cnt
    where
      sdocIgnore :: SDoc
sdocIgnore = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Ignore count" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
str)

setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m()
setupBreakpoint :: forall (m :: Type -> Type). GhciMonad m => BreakInfo -> Int -> m ()
setupBreakpoint BreakInfo
loc Int
count = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    HscEnv -> BreakInfo -> Int -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
HscEnv -> BreakInfo -> Int -> m ()
GHC.setupBreakpoint HscEnv
hsc_env BreakInfo
loc Int
count

backCmd :: GhciMonad m => String -> m ()
backCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
backCmd [Char]
arg
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
arg        = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
back Int
1
  | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
arg = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
back ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg)
  | Bool
otherwise       = IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Syntax:  :back [num]"
  where
  back :: Int -> m ()
back Int
num = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":back" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ([Name]
names, Int
_, SrcSpan
pan, [Char]
_) <- Int -> m ([Name], Int, SrcSpan, [Char])
forall (m :: Type -> Type).
GhcMonad m =>
Int -> m ([Name], Int, SrcSpan, [Char])
GHC.back Int
num
      SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Logged breakpoint at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
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
      [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [GHCiState -> [Char]
stop GHCiState
st]

forwardCmd :: GhciMonad m => String -> m ()
forwardCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
forwardCmd [Char]
arg
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
arg        = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
forward Int
1
  | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
arg = Int -> m ()
forall (m :: Type -> Type). GhciMonad m => Int -> m ()
forward ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg)
  | Bool
otherwise       = IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Syntax:  :forward [num]"
  where
  forward :: Int -> m ()
forward Int
num = [Char] -> m () -> m ()
forall (m :: Type -> Type). GhcMonad m => [Char] -> m () -> m ()
withSandboxOnly [Char]
":forward" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ([Name]
names, Int
ix, SrcSpan
pan, [Char]
_) <- Int -> m ([Name], Int, SrcSpan, [Char])
forall (m :: Type -> Type).
GhcMonad m =>
Int -> m ([Name], Int, SrcSpan, [Char])
GHC.forward Int
num
      SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ (if (Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
                        then [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Stopped at"
                        else [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Logged breakpoint at") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
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
      [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
enqueueCommands [GHCiState -> [Char]
stop GHCiState
st]

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

breakSwitch :: GhciMonad m => [String] -> m ()
breakSwitch :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
breakSwitch [] = do
   IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"The break command requires at least one argument."
breakSwitch ([Char]
arg1:[[Char]]
rest)
   | [Char] -> Bool
looksLikeModuleName [Char]
arg1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [[Char]]
rest) = do
        GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
wantInterpretedModule [Char]
arg1
        GenModule Unit -> [[Char]] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> [[Char]] -> m ()
breakByModule GenModule Unit
md [[Char]]
rest
   | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
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
              GenModule Unit
md <- ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
lookupModuleName ModuleName
mn
              GenModule Unit -> Int -> [[Char]] -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> Int -> [[Char]] -> m ()
breakByModuleLine GenModule Unit
md ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg1) [[Char]]
rest
           [] -> do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"No modules are loaded with debugging support."
   | Bool
otherwise = do -- try parsing it as an identifier
        [Char] -> m ()
forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
breakById [Char]
arg1

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

breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
breakByModuleLine :: forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> Int -> [[Char]] -> m ()
breakByModuleLine GenModule Unit
md Int
line [[Char]]
args
   | [] <- [[Char]]
args = GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet GenModule Unit
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
   | [[Char]
col] <- [[Char]]
args, (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
col =
        GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet GenModule Unit
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, [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
col)
   | Bool
otherwise = m ()
forall a. a
breakSyntax

-- Set a breakpoint for an identifier
-- See Note [Setting Breakpoints by Id]
breakById :: GhciMonad m => String -> m ()                          -- #3000
breakById :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
breakById [Char]
inp = do
    let ([Char]
mod_str, [Char]
top_level, [Char]
fun_str) = [Char] -> ([Char], [Char], [Char])
splitIdent [Char]
inp
        mod_top_lvl :: [Char]
mod_top_lvl = [Char] -> [Char] -> [Char]
combineModIdent [Char]
mod_str [Char]
top_level
    Maybe (GenModule Unit)
mb_mod <- m (Maybe (GenModule Unit))
-> (SomeException -> m (Maybe (GenModule Unit)))
-> m (Maybe (GenModule Unit))
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch ([Char] -> m (Maybe (GenModule Unit))
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe (GenModule Unit))
lookupModuleInscope [Char]
mod_top_lvl)
                    (\(SomeException
_ :: SomeException) -> [Char] -> m (Maybe (GenModule Unit))
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe (GenModule Unit))
lookupModuleInGraph [Char]
mod_str)
      -- If the top-level name is not in scope, `lookupModuleInscope` will
      -- throw an exception, then lookup the module name in the module graph.
    Maybe SDoc
mb_err_msg <- [Char] -> [Char] -> Maybe (GenModule Unit) -> m (Maybe SDoc)
forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> [Char] -> Maybe (GenModule Unit) -> m (Maybe SDoc)
validateBP [Char]
mod_str [Char]
fun_str Maybe (GenModule Unit)
mb_mod
    case Maybe SDoc
mb_err_msg of
        Just SDoc
err_msg -> SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Cannot set breakpoint on" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
inp)
          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
":" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
err_msg
        Maybe SDoc
Nothing -> do
          -- No errors found, go and set the breakpoint
          Maybe ModuleInfo
mb_mod_info  <- GenModule Unit -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Maybe ModuleInfo)
GHC.getModuleInfo (GenModule Unit -> m (Maybe ModuleInfo))
-> GenModule Unit -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ Maybe (GenModule Unit) -> GenModule Unit
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (GenModule Unit)
mb_mod
          let modBreaks :: ModBreaks
modBreaks = case Maybe ModuleInfo
mb_mod_info of
                (Just ModuleInfo
mod_info) -> ModuleInfo -> ModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
                Maybe ModuleInfo
Nothing         -> ModBreaks
emptyModBreaks
          GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet (Maybe (GenModule Unit) -> GenModule Unit
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (GenModule Unit)
mb_mod) ((TickArray -> [(Int, RealSrcSpan)]) -> m ())
-> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ModBreaks -> TickArray -> [(Int, RealSrcSpan)]
findBreakForBind [Char]
fun_str ModBreaks
modBreaks
  where
    -- Try to lookup the module for an identifier that is in scope.
    -- `parseName` throws an exception, if the identifier is not in scope
    lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
    lookupModuleInscope :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe (GenModule Unit))
lookupModuleInscope [Char]
mod_top_lvl = do
        NonEmpty Name
names <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
mod_top_lvl
        Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (GenModule Unit) -> m (Maybe (GenModule Unit)))
-> Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> Maybe (GenModule Unit)
forall a. a -> Maybe a
Just (GenModule Unit -> Maybe (GenModule Unit))
-> GenModule Unit -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ NonEmpty (GenModule Unit) -> GenModule Unit
forall a. NonEmpty a -> a
NE.head (NonEmpty (GenModule Unit) -> GenModule Unit)
-> NonEmpty (GenModule Unit) -> GenModule Unit
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
GHC.nameModule (Name -> GenModule Unit)
-> NonEmpty Name -> NonEmpty (GenModule Unit)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Name
names

    -- Lookup the Module of a module name in the module graph
    lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
    lookupModuleInGraph :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> m (Maybe (GenModule Unit))
lookupModuleInGraph [Char]
mod_str = do
        ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
        let hmods :: [GenModule Unit]
hmods = ModSummary -> GenModule Unit
ms_mod (ModSummary -> GenModule Unit) -> [ModSummary] -> [GenModule Unit]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
graph
        Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (GenModule Unit) -> m (Maybe (GenModule Unit)))
-> Maybe (GenModule Unit) -> m (Maybe (GenModule Unit))
forall a b. (a -> b) -> a -> b
$ (GenModule Unit -> Bool)
-> [GenModule Unit] -> Maybe (GenModule Unit)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
mod_str) ([Char] -> Bool)
-> (GenModule Unit -> [Char]) -> GenModule Unit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> [Char]
showModule) [GenModule Unit]
hmods

    -- Check validity of an identifier to set a breakpoint:
    --  1. The module of the identifier must exist
    --  2. the identifier must be in an interpreted module
    --  3. the ModBreaks array for module `mod` must have an entry
    --     for the function
    validateBP :: GhciMonad m => String -> String -> Maybe Module
                       -> m (Maybe SDoc)
    validateBP :: forall (m :: Type -> Type).
GhciMonad m =>
[Char] -> [Char] -> Maybe (GenModule Unit) -> m (Maybe SDoc)
validateBP [Char]
mod_str [Char]
fun_str Maybe (GenModule Unit)
Nothing = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
quotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text
        ([Char] -> [Char] -> [Char]
combineModIdent [Char]
mod_str ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') [Char]
fun_str)))
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not in scope"
    validateBP [Char]
_ [Char]
"" (Just GenModule Unit
_) = Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Function name is missing"
    validateBP [Char]
_ [Char]
fun_str (Just GenModule Unit
modl) = do
        Bool
isInterpr <- GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.moduleIsInterpreted GenModule Unit
modl
        (Array Int SrcSpan
_, Array Int [[Char]]
decls) <- GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
getModBreak GenModule Unit
modl
        Maybe SDoc
mb_err_msg <- case Bool
isInterpr of
          Bool
False -> Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenModule Unit
modl)
                        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"is not interpreted"
          Bool
True -> case [Char]
fun_str [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ([[Char]] -> [Char]
declPath ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Array Int [[Char]] -> [[[Char]]]
forall i e. Array i e -> [e]
elems Array Int [[Char]]
decls) of
                Bool
False -> Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe SDoc -> m (Maybe SDoc)) -> Maybe SDoc -> m (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
                   [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"No breakpoint found for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
fun_str)
                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
"in module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenModule Unit
modl)
                Bool
True  -> Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe SDoc
forall a. Maybe a
Nothing
        Maybe SDoc -> m (Maybe SDoc)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe SDoc
mb_err_msg

breakSyntax :: a
breakSyntax :: forall a. a
breakSyntax = GhcException -> a
forall a. GhcException -> a
throwGhcException (GhcException -> a) -> GhcException -> a
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
CmdLineError ([Char]
"Syntax: :break [<mod>.]<func>[.<func>]\n"
                                             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"        :break [<mod>] <line> [<column>]")

findBreakAndSet :: GhciMonad m
                => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet :: forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet GenModule Unit
md TickArray -> [(Int, RealSrcSpan)]
lookupTickTree = do
   TickArray
tickArray <- GenModule Unit -> m TickArray
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> m TickArray
getTickArray GenModule Unit
md
   case TickArray -> [(Int, RealSrcSpan)]
lookupTickTree TickArray
tickArray of
      []  -> IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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_ (Int, RealSrcSpan) -> m ()
breakAt [(Int, RealSrcSpan)]
some
 where
   breakAt :: (Int, RealSrcSpan) -> m ()
breakAt (Int
tick, RealSrcSpan
pan) = do
         GenModule Unit -> Int -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> Int -> Bool -> m ()
setBreakFlag GenModule Unit
md Int
tick Bool
True
         (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
                       { breakModule :: GenModule Unit
breakModule = GenModule Unit
md
                       , breakLoc :: SrcSpan
breakLoc = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
pan Maybe BufSpan
forall a. Maybe a
Strict.Nothing
                       , breakTick :: Int
breakTick = Int
tick
                       , onBreakCmd :: [Char]
onBreakCmd = [Char]
""
                       , breakEnabled :: Bool
breakEnabled = Bool
True
                       }
         SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Breakpoint " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
            if Bool
alreadySet
               then [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" was already set at " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
pan
               else [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" activated at " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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
ends_here [(Int, RealSrcSpan)]
starts_here
            where ends_here :: (Int, RealSrcSpan) -> Bool
ends_here (Int
_,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 (it maybe a top-level or a nested declaration)
--   (b) that do not have an enclosing breakpoint
findBreakForBind :: String -> GHC.ModBreaks -> TickArray
                 -> [(BreakIndex,RealSrcSpan)]
findBreakForBind :: [Char] -> ModBreaks -> TickArray -> [(Int, RealSrcSpan)]
findBreakForBind [Char]
str_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
enclosed) [(Int, RealSrcSpan)]
ticks
  where
    ticks :: [(Int, RealSrcSpan)]
ticks = [ (Int
index, RealSrcSpan
span)
            | (Int
index, [[Char]]
decls) <- Array Int [[Char]] -> [(Int, [[Char]])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (ModBreaks -> Array Int [[Char]]
GHC.modBreaks_decls ModBreaks
modbreaks),
              [Char]
str_name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Char]] -> [Char]
declPath [[Char]]
decls,
              RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- [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 :: (Int, RealSrcSpan) -> Bool
enclosed (Int
_,RealSrcSpan
sp0) = ((Int, RealSrcSpan) -> Bool) -> [(Int, RealSrcSpan)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Int, RealSrcSpan) -> Bool
subspan [(Int, RealSrcSpan)]
ticks
      where subspan :: (Int, RealSrcSpan) -> Bool
subspan (Int
_,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 -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
pan Maybe BufSpan
forall a. Maybe a
Strict.Nothing 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 = ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` IO [Char] -> [Char]
forall a. IO a -> a
unsafePerformIO IO [Char]
mTerm) ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
`any` [[Char]
"xterm", [Char]
"linux"]
    where mTerm :: IO [Char]
mTerm = [Char] -> IO [Char]
System.Environment.getEnv [Char]
"TERM"
                  IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Char]
"TERM not set"

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

{-
Note [Setting Breakpoints by Id]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To set a breakpoint first check whether a ModBreaks array contains a
breakpoint with the given function name:
In `:break M.foo` `M` may be a module name or a local alias of an import
statement. To lookup a breakpoint in the ModBreaks, the effective module
name is needed. Even if a module called `M` exists, `M` may still be
a local alias. To get the module name, parse the top-level identifier with
`GHC.parseName`. If this succeeds, extract the module name from the
returned value. If it fails, catch the exception and assume `M` is a real
module name.

The names of nested functions are stored in `ModBreaks.modBreaks_decls`.
-}

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

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

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

listCmd :: GhciMonad m => String -> m ()
listCmd :: forall (m :: Type -> Type). GhciMonad m => [Char] -> m ()
listCmd [Char]
"" = 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 ->
          SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Not stopped at a breakpoint; nothing to list"
      Just (RealSrcSpan RealSrcSpan
pan Maybe BufSpan
_) ->
          RealSrcSpan -> Bool -> m ()
forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround RealSrcSpan
pan Bool
True
      Just pan :: SrcSpan
pan@(UnhelpfulSpan UnhelpfulSpanReason
_) ->
          do [Resume]
resumes <- m [Resume]
forall (m :: Type -> Type). GhcMonad m => m [Resume]
GHC.getResumeContext
             case [Resume]
resumes of
                 [] -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"No resumes"
                 (Resume
r:[Resume]
_) ->
                     do let traceIt :: SDoc
traceIt = case Resume -> [History]
GHC.resumeHistory Resume
r of
                                      [] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rerunning with :trace,"
                                      [History]
_ -> SDoc
forall doc. IsOutput doc => doc
empty
                            doWhat :: SDoc
doWhat = SDoc
traceIt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
":back then :list"
                        SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Unable to list source for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                      SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
pan
                                   SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Try" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doWhat)
listCmd [Char]
str = [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
list2 ([Char] -> [[Char]]
words [Char]
str)

list2 :: GhciMonad m => [String] -> m ()
list2 :: forall (m :: Type -> Type). GhciMonad m => [[Char]] -> m ()
list2 [[Char]
arg] | (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
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 a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"No module to list"
        (ModuleName
mn : [ModuleName]
_) -> do
          GenModule Unit
md <- ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
lookupModuleName ModuleName
mn
          GenModule Unit -> Int -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> Int -> m ()
listModuleLine GenModule Unit
md ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg)
list2 [[Char]
arg1,[Char]
arg2] | [Char] -> Bool
looksLikeModuleName [Char]
arg1, (Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
arg2 = do
        GenModule Unit
md <- [Char] -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
wantInterpretedModule [Char]
arg1
        GenModule Unit -> Int -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> Int -> m ()
listModuleLine GenModule Unit
md ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
arg2)
list2 [[Char]
arg] = do
        (Name -> SDoc -> m ()) -> [Char] -> (Name -> m ()) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(Name -> SDoc -> m ()) -> [Char] -> (Name -> m ()) -> m ()
wantNameFromInterpretedModule Name -> SDoc -> m ()
forall {m :: Type -> Type} {a}.
(GhcMonad m, Outputable a) =>
a -> SDoc -> m ()
noCanDo [Char]
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 Maybe BufPos
_ ->
               do TickArray
tickArray <- Bool -> m TickArray -> m TickArray
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isExternalName Name
name) (m TickArray -> m TickArray) -> m TickArray -> m TickArray
forall a b. (a -> b) -> a -> b
$
                               GenModule Unit -> m TickArray
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> m TickArray
getTickArray ((() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
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 -> SDoc -> m ()
forall {m :: Type -> Type} {a}.
(GhcMonad m, Outputable a) =>
a -> SDoc -> m ()
noCanDo Name
name (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"can't find its location: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                                 SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcLoc
loc
    where
        noCanDo :: a -> SDoc -> m ()
noCanDo a
n SDoc
why = SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cannot list source code for " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
": " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
why
list2  [[Char]]
_other =
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"syntax:  :list [<line> | <module> <line> | <identifier>]"

listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()
listModuleLine :: forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> Int -> m ()
listModuleLine GenModule Unit
modl Int
line = do
   ModuleGraph
graph <- m ModuleGraph
forall (m :: Type -> Type). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
   let this :: Maybe ModSummary
this = ModuleGraph -> GenModule Unit -> Maybe ModSummary
GHC.mgLookupModule ModuleGraph
graph GenModule Unit
modl
   case Maybe ModSummary
this of
     Maybe ModSummary
Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"listModuleLine"
     Just ModSummary
summ -> do
           let filename :: [Char]
filename = [Char] -> Maybe [Char] -> [Char]
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"listModuleLine" (ModLocation -> Maybe [Char]
ml_hs_file (ModSummary -> ModLocation
GHC.ms_location ModSummary
summ))
               loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString ([Char]
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 :: forall (m :: Type -> Type).
MonadIO m =>
RealSrcSpan -> Bool -> m ()
listAround RealSrcSpan
pan Bool
do_highlight = do
      ByteString
contents <- IO ByteString -> m ByteString
forall a. IO a -> m a
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
$ [Char] -> IO ByteString
BS.readFile (FastString -> [Char]
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 = [ [Char] -> ByteString
BS.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  ") | 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 ([Char] -> ByteString
BS.pack [Char]
"\n") [ByteString]
prefixed

      let utf8Decoded :: [Char]
utf8Decoded = ByteString -> [Char]
utf8DecodeByteString ByteString
output
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
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,[Char] -> ByteString
BS.pack [Char]
start_bold,ByteString
b,[Char] -> ByteString
BS.pack [Char]
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, [Char] -> ByteString
BS.pack [Char]
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, [Char] -> ByteString
BS.pack [Char]
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
' ', [Char] -> ByteString
BS.pack [Char]
"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
' ',
                                         [Char] -> ByteString
BS.pack [Char]
"^^"]
          | Bool
otherwise   = [ByteString] -> ByteString
BS.concat [ByteString
prefix, ByteString
line]
         where
           indent :: ByteString
indent = [Char] -> ByteString
BS.pack ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
no)) Char
' ')
           nl :: ByteString
nl = Char -> ByteString
BS.singleton Char
'\n'


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

getTickArray :: GhciMonad m => Module -> m TickArray
getTickArray :: forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> m TickArray
getTickArray GenModule Unit
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 -> GenModule Unit -> Maybe TickArray
forall a. ModuleEnv a -> GenModule Unit -> Maybe a
lookupModuleEnv ModuleEnv TickArray
arrmap GenModule Unit
modl of
      Just TickArray
arr -> TickArray -> m TickArray
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return TickArray
arr
      Maybe TickArray
Nothing  -> do
        (Array Int SrcSpan
ticks, Array Int [[Char]]
_) <- GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
getModBreak GenModule Unit
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 = extendModuleEnv arrmap modl arr}
        TickArray -> m TickArray
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return TickArray
arr

discardTickArrays :: GhciMonad m => m ()
discardTickArrays :: forall (m :: Type -> Type). GhciMonad m => m ()
discardTickArrays = (GHCiState -> GHCiState) -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
(GHCiState -> GHCiState) -> m ()
modifyGHCiState (\GHCiState
st -> GHCiState
st {tickarrays = 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 Maybe BufSpan
_) <- [(Int, SrcSpan)]
ticks, Int
line <- RealSrcSpan -> [Int]
srcSpanLines RealSrcSpan
pan ]
    where
        max_line :: Int
max_line = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
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 Maybe BufSpan
_) <- [(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 :: forall (m :: Type -> Type). GhciMonad m => 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).
GhciMonad 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.empty }

discardInterfaceCache :: GhciMonad m => m ()
discardInterfaceCache :: forall (m :: Type -> Type). GhciMonad m => m ()
discardInterfaceCache =
   m [CachedIface] -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (IO [CachedIface] -> m [CachedIface]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [CachedIface] -> m [CachedIface])
-> (GHCiState -> IO [CachedIface]) -> GHCiState -> m [CachedIface]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIfaceCache -> IO [CachedIface]
iface_clearCache (ModIfaceCache -> IO [CachedIface])
-> (GHCiState -> ModIfaceCache) -> GHCiState -> IO [CachedIface]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCiState -> ModIfaceCache
ifaceCache (GHCiState -> m [CachedIface]) -> m GHCiState -> m [CachedIface]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState)

clearHPTs :: GhciMonad m => m ()
clearHPTs :: forall (m :: Type -> Type). GhciMonad m => m ()
clearHPTs = do
  let pruneHomeUnitEnv :: HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv HomeUnitEnv
hme = HomeUnitEnv
hme { homeUnitEnv_hpt = emptyHomePackageTable }
      discardMG :: HscEnv -> HscEnv
discardMG HscEnv
hsc = HscEnv
hsc { hsc_mod_graph = GHC.emptyMG }
  (HscEnv -> HscEnv) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(HscEnv -> HscEnv) -> m ()
modifySession (HscEnv -> HscEnv
discardMG (HscEnv -> HscEnv) -> (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG ((HomeUnitEnv -> HomeUnitEnv) -> HomeUnitGraph -> HomeUnitGraph
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv))


-- The unused package warning doesn't make sense once the targets get out of
-- sync with the package flags. See #21110
-- Therefore if it's turned on, the warnings are issued until the module context
-- changes (via :load or :cd), at which stage the package flags are not going to change
-- but the loaded modules will probably not use all the specified packages so the
-- warning becomes spurious. At that point the warning is silently disabled.
disableUnusedPackages :: GhciMonad m => m ()
disableUnusedPackages :: forall (m :: Type -> Type). GhciMonad m => m ()
disableUnusedPackages = Bool -> [[Char]] -> m ()
forall (m :: Type -> Type). GhciMonad m => Bool -> [[Char]] -> m ()
newDynFlags Bool
False [[Char]
"-Wno-unused-packages"]

deleteBreak :: GhciMonad m => Int -> m ()
deleteBreak :: forall (m :: Type -> Type). GhciMonad m => 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 -> SDoc -> m ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
printForUser ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Breakpoint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
identity SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"does not exist")
       Just BreakLocation
loc -> do
           BreakLocation
_ <- (Bool -> BreakLocation -> m BreakLocation
forall (m :: Type -> Type).
GhciMonad 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 = rest }

turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation
turnBreakOnOff :: forall (m :: Type -> Type).
GhciMonad m =>
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return BreakLocation
loc
  | Bool
otherwise = do
      GenModule Unit -> Int -> Bool -> m ()
forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> Int -> Bool -> m ()
setBreakFlag (BreakLocation -> GenModule Unit
breakModule BreakLocation
loc) (BreakLocation -> Int
breakTick BreakLocation
loc)  Bool
onOff
      BreakLocation -> m BreakLocation
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return BreakLocation
loc { breakEnabled = onOff }

getModBreak :: GHC.GhcMonad m
            => Module -> m (Array Int SrcSpan, Array Int [String])
getModBreak :: forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Array Int SrcSpan, Array Int [[Char]])
getModBreak GenModule Unit
m = do
   ModuleInfo
mod_info      <- ModuleInfo -> Maybe ModuleInfo -> ModuleInfo
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ModuleInfo
forall a. HasCallStack => [Char] -> a
panic [Char]
"getModBreak") (Maybe ModuleInfo -> ModuleInfo)
-> m (Maybe ModuleInfo) -> m ModuleInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> GenModule Unit -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
GenModule Unit -> m (Maybe ModuleInfo)
GHC.getModuleInfo GenModule Unit
m
   let modBreaks :: ModBreaks
modBreaks  = ModuleInfo -> ModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
   let ticks :: Array Int SrcSpan
ticks      = ModBreaks -> Array Int SrcSpan
GHC.modBreaks_locs  ModBreaks
modBreaks
   let decls :: Array Int [[Char]]
decls      = ModBreaks -> Array Int [[Char]]
GHC.modBreaks_decls ModBreaks
modBreaks
   (Array Int SrcSpan, Array Int [[Char]])
-> m (Array Int SrcSpan, Array Int [[Char]])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Array Int SrcSpan
ticks, Array Int [[Char]]
decls)

setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()
setBreakFlag :: forall (m :: Type -> Type).
GhciMonad m =>
GenModule Unit -> Int -> Bool -> m ()
setBreakFlag  GenModule Unit
md Int
ix Bool
enaDisa = do
  let enaDisaToCount :: Bool -> Int
enaDisaToCount Bool
True = Int
breakOn
      enaDisaToCount Bool
False = Int
breakOff
  BreakInfo -> Int -> m ()
forall (m :: Type -> Type). GhciMonad m => BreakInfo -> Int -> m ()
setupBreakpoint (GenModule Unit -> Int -> BreakInfo
GHC.BreakInfo GenModule Unit
md Int
ix) (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Int
enaDisaToCount Bool
enaDisa

-- ---------------------------------------------------------------------------
-- 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 around 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 :: forall (m :: Type -> Type). GhciMonad m => 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 => 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.
(HasLogger 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 a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False)

showException :: MonadIO m => SomeException -> m ()
showException :: forall (m :: Type -> Type). MonadIO m => SomeException -> m ()
showException SomeException
se =
  IO () -> m ()
forall a. IO a -> m a
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 [Char]
s)    -> [Char] -> IO ()
putException [Char]
s
           -- ditto:
           Just GhcException
other_ghc_ex        -> [Char] -> IO ()
putException (GhcException -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> IO ()
putException [Char]
"Interrupted."
               Maybe AsyncException
_                  -> [Char] -> IO ()
putException ([Char]
"*** Exception: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
se)
  where
    putException :: [Char] -> IO ()
putException = Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr

failIfExprEvalMode :: GhciMonad m => m ()
failIfExprEvalMode :: forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode = do
  GHCiState
s <- m GHCiState
forall (m :: Type -> Type). GhciMonad m => m GHCiState
getGHCiState
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (GHCiState -> Bool
ghc_e GHCiState
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall a. IO a -> m a
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))

-- | When in expression evaluation mode (ghc -e), we want to exit immediately.
-- Otherwis, just print out the message.
printErrAndMaybeExit :: (GhciMonad m, MonadIO m, HasLogger m) => SourceError -> m ()
printErrAndMaybeExit :: forall (m :: Type -> Type).
(GhciMonad m, MonadIO m, HasLogger m) =>
SourceError -> m ()
printErrAndMaybeExit = (m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
failIfExprEvalMode) (m () -> m ()) -> (SourceError -> m ()) -> SourceError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException

-----------------------------------------------------------------------------
-- 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 :: (HasLogger m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
ghciHandle :: forall (m :: Type -> Type) a.
(HasLogger m, ExceptionMonad m) =>
(SomeException -> m a) -> m a -> m a
ghciHandle SomeException -> m a
h m a
m = ((forall a. m a -> m a) -> m a) -> m a
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: Type -> Type) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
                 -- Force dflags to avoid leaking the associated HscEnv
                 !Logger
log <- m Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
                 m a -> (SomeException -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (m a -> m a
forall a. m a -> m a
restore (Logger -> m a -> m a
forall (m :: Type -> Type) a.
ExceptionMonad m =>
Logger -> m a -> m a
GHC.prettyPrintGhcErrors Logger
log 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
forall a. m a -> m a
restore (SomeException -> m a
h SomeException
e)

ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
ghciTry :: forall (m :: Type -> Type) a.
ExceptionMonad m =>
m a -> m (Either SomeException a)
ghciTry m a
m = (a -> Either SomeException a) -> m a -> m (Either SomeException a)
forall a b. (a -> b) -> m a -> m b
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 e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> Either SomeException a -> m (Either SomeException a)
forall a. a -> m 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 :: forall (m :: Type -> Type) a. ExceptionMonad m => 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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
      Right a
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True

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

lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule :: forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
lookupModule [Char]
mName = ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
lookupModuleName ([Char] -> ModuleName
GHC.mkModuleName [Char]
mName)

lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
lookupModuleName :: forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
lookupModuleName ModuleName
mName = PkgQual -> ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
PkgQual -> ModuleName -> m (GenModule Unit)
GHC.lookupQualifiedModule PkgQual
NoPkgQual ModuleName
mName

isMainUnitModule :: Module -> Bool
isMainUnitModule :: GenModule Unit -> Bool
isMainUnitModule GenModule Unit
m = GenModule Unit -> Unit
forall unit. GenModule unit -> unit
GHC.moduleUnit GenModule Unit
m Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit

showModule :: Module -> String
showModule :: GenModule Unit -> [Char]
showModule = ModuleName -> [Char]
moduleNameString (ModuleName -> [Char])
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName

-- Return a String with the declPath of the function of a breakpoint.
-- See Note [Field modBreaks_decls] in GHC.ByteCode.Types
declPath :: [String] -> String
declPath :: [[Char]] -> [Char]
declPath = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"."

-- | Optionally show a fixity declaration like @infixr 4 #@
--
-- We always display the fixity of terms with symbolic names (like <$>).
-- For other terms we only display the fixity if it has been set to a
-- value other than the default infixl 9.
--
-- We have no way of distinguishing between a fixity that has been
-- manually set to infixl 9 and a fixity that has assumed infixl 9 as
-- the default, so we choose to not display the fixity in both cases
-- (for terms with non-symbolic names).
--
-- See #19200.
showFixity :: TyThing -> Fixity -> SDoc
showFixity :: TyThing -> Fixity -> SDoc
showFixity TyThing
thing Fixity
fixity
    | Fixity
fixity Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixity
GHC.defaultFixity Bool -> Bool -> Bool
|| OccName -> Bool
isSymOcc (TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyThing
thing)
        = Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fixity
fixity SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
thing)
    | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty

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

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

wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
wantInterpretedModule :: forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (GenModule Unit)
wantInterpretedModule [Char]
str = ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
wantInterpretedModuleName ([Char] -> ModuleName
GHC.mkModuleName [Char]
str)

wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName :: forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
wantInterpretedModuleName ModuleName
modname = do
   GenModule Unit
modl <- ModuleName -> m (GenModule Unit)
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> m (GenModule Unit)
lookupModuleName ModuleName
modname
   let str :: [Char]
str = ModuleName -> [Char]
moduleNameString ModuleName
modname
   HomeUnit
home_unit <- HscEnv -> HomeUnit
hsc_home_unit (HscEnv -> HomeUnit) -> m HscEnv -> m HomeUnit
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
   Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (HomeUnit -> GenModule Unit -> Bool
isHomeModule HomeUnit
home_unit GenModule Unit
modl) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      GhcException -> m ()
forall a. GhcException -> a
throwGhcException ([Char] -> GhcException
CmdLineError ([Char]
"module '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' is from another package;\nthis command requires an interpreted module"))
   Bool
is_interpreted <- GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.moduleIsInterpreted GenModule Unit
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 ([Char] -> GhcException
CmdLineError ([Char]
"module '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' is not interpreted; try \':add *" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' first"))
   GenModule Unit -> m (GenModule Unit)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return GenModule Unit
modl

wantNameFromInterpretedModule :: GHC.GhcMonad m
                              => (Name -> SDoc -> m ())
                              -> String
                              -> (Name -> m ())
                              -> m ()
wantNameFromInterpretedModule :: forall (m :: Type -> Type).
GhcMonad m =>
(Name -> SDoc -> m ()) -> [Char] -> (Name -> m ()) -> m ()
wantNameFromInterpretedModule Name -> SDoc -> m ()
noCanDo [Char]
str Name -> m ()
and_then =
  (SourceError -> m ()) -> m () -> m ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Name
n NE.:| [Name]
_ <- [Char] -> m (NonEmpty Name)
forall (m :: Type -> Type).
GhcMonad m =>
[Char] -> m (NonEmpty Name)
GHC.parseName [Char]
str
    let modl :: GenModule Unit
modl = Bool -> GenModule Unit -> GenModule Unit
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isExternalName Name
n) (GenModule Unit -> GenModule Unit)
-> GenModule Unit -> GenModule Unit
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
GHC.nameModule Name
n
    if Bool -> Bool
not (Name -> Bool
GHC.isExternalName Name
n)
       then Name -> SDoc -> m ()
noCanDo Name
n (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" is not defined in an interpreted module"
       else do
    Bool
is_interpreted <- GenModule Unit -> m Bool
forall (m :: Type -> Type). GhcMonad m => GenModule Unit -> m Bool
GHC.moduleIsInterpreted GenModule Unit
modl
    if Bool -> Bool
not Bool
is_interpreted
       then Name -> SDoc -> m ()
noCanDo Name
n (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> GenModule Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenModule Unit
modl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" is not interpreted"
       else Name -> m ()
and_then Name
n

clearCaches :: GhciMonad m => m ()
clearCaches :: forall (m :: Type -> Type). GhciMonad m => m ()
clearCaches = m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardActiveBreakPoints
              m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
discardInterfaceCache
              m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
disableUnusedPackages
              m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: Type -> Type). GhciMonad m => m ()
clearHPTs



-- Split up a string with an eventually qualified declaration name into 3 components
--   1. module name
--   2. top-level decl
--   3. full-name of the eventually nested decl, but without module qualification
-- eg  "foo"           = ("", "foo", "foo")
--     "A.B.C.foo"     = ("A.B.C", "foo", "foo")
--     "M.N.foo.bar"   = ("M.N", "foo", "foo.bar")
splitIdent :: String -> (String, String, String)
splitIdent :: [Char] -> ([Char], [Char], [Char])
splitIdent [] = ([Char]
"", [Char]
"", [Char]
"")
splitIdent inp :: [Char]
inp@(Char
a : [Char]
_)
    | (Char -> Bool
isUpper Char
a) = case [Int]
fixs of
        []            -> ([Char]
inp, [Char]
"", [Char]
"")
        (Int
i1 : [] )    -> (Int -> [Char]
upto Int
i1, Int -> [Char]
from Int
i1, Int -> [Char]
from Int
i1)
        (Int
i1 : Int
i2 : [Int]
_) -> (Int -> [Char]
upto Int
i1, Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
i2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [Char]
from Int
i1), Int -> [Char]
from Int
i1)
    | Bool
otherwise = case [Int]
ixs of
        []            -> ([Char]
"", [Char]
inp, [Char]
inp)
        (Int
i1 : [Int]
_)      -> ([Char]
"", Int -> [Char]
upto Int
i1, [Char]
inp)
  where
    ixs :: [Int]
ixs = Char -> [Char] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices Char
'.' [Char]
inp        -- indices of '.' in whole input
    fixs :: [Int]
fixs = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Int -> Bool
isNextUc [Int]
ixs    -- indices of '.' in function names              --
    isNextUc :: Int -> Bool
isNextUc Int
ix = Char -> Bool
isUpper (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
safeInp [Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    safeInp :: [Char]
safeInp = [Char]
inp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" "
    upto :: Int -> [Char]
upto Int
i = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
i [Char]
inp
    from :: Int -> [Char]
from Int
i = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char]
inp

-- Qualify an identifier name with a module name
-- combineModIdent "A" "foo"  =  "A.foo"
-- combineModIdent ""  "foo"  =  "foo"
combineModIdent :: String -> String -> String
combineModIdent :: [Char] -> [Char] -> [Char]
combineModIdent [Char]
mod [Char]
ident
          | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
mod   = [Char]
ident
          | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Char]
ident = [Char]
mod
          | Bool
otherwise  = [Char]
mod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ident