{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

{- |
A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.

For a full example see the "Ide.Plugin.Eval.Tutorial" module.
-}
module Ide.Plugin.Eval.CodeLens (
    codeLens,
    evalCommand,
) where

import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second, (>>>))
import qualified Control.Exception as E
import Control.Monad
    ( void,
      when, guard,
      join
    )
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Except
    ( ExceptT (..),
    )
import Data.Aeson (toJSON)
import Data.Char (isSpace)
import qualified Data.HashMap.Strict as HashMap
import Data.List
    (dropWhileEnd,
      find, intercalate
    )
import qualified Data.Map.Strict as Map
import Data.Maybe
    ( catMaybes,
      fromMaybe,
    )
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Data.Typeable (Typeable)
import Development.IDE
    ( Action,
      realSrcSpanToRange,  GetModSummary (..),
      GetParsedModuleWithComments (..),
      HscEnvEq,
      IdeState,
      evalGhcEnv,
      hscEnvWithImportPaths,
      runAction,
      textToStringBuffer,
      toNormalizedFilePath',
      uriToFilePath',
      useWithStale_,
      prettyPrint,
      use_, useNoFile_, uses_,
      GhcSessionIO(..), GetDependencies(..), GetModIface(..),
      HiFileResult (hirHomeMod, hirModSummary)
    )
import Development.IDE.Core.Rules (TransitiveDependencies(transitiveModuleDeps))
import Development.IDE.Core.Compile (setupFinderCache, loadModulesHome)
import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan, UnhelpfulSpan), srcSpanFile, GhcException, setInteractiveDynFlags)
import Development.IDE.Types.Options
import DynamicLoading (initializePlugins)
import FastString (unpackFS)
import GHC
    (ExecOptions
        ( execLineNumber,
          execSourceFile
        ),
      ExecResult (..),
      GeneralFlag (..),
      Ghc,
      GhcLink (LinkInMemory),
      GhcMode (CompManager),
      GhcMonad (getSession),
      HscTarget (HscInterpreted),
      LoadHowMuch (LoadAllTargets),
      ModSummary (ms_hspp_opts),
      Module (moduleName),
      SuccessFlag (Failed, Succeeded),
      TcRnExprMode (..),
      execOptions,
      execStmt,
      exprType,
      getInteractiveDynFlags,
      getSessionDynFlags,
      isImport,
      isStmt,
      load,
      runDecls,
      setContext,
      setLogAction,
      setSessionDynFlags,
      setTargets,
      typeKind,
    )
import GhcPlugins
    ( DynFlags (..),
      hsc_dflags,
      defaultLogActionHPutStrDoc,
      gopt_set,
      gopt_unset,
      interpWays,
      targetPlatform,
      updateWays,
      wayGeneralFlags,
      wayUnsetGeneralFlags,
      xopt_set, parseDynamicFlagsCmdLine
    )
import HscTypes
    ( InteractiveImport (IIModule),
      ModSummary (ms_mod),
      Target (Target),
      TargetId (TargetFile),
    )
import Ide.Plugin.Eval.Code
    ( Statement,
      asStatements,
      evalExpr,
      evalExtensions,
      evalSetup,
      propSetup,
      resultRange,
      testCheck,
      testRanges,
    )
import Ide.Plugin.Eval.GHC
    ( addImport,
      addPackages,
      hasPackage,
      isExpr,
      showDynFlags,
    )
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
import Ide.Plugin.Eval.Types
import Ide.Plugin.Eval.Util
    ( asS,
      gStrictTry,
      handleMaybe,
      handleMaybeM,
      isLiterate,
      logWith,
      response,
      response',
      timed,
    )
import Ide.Types
import Language.LSP.Server
import Language.LSP.Types
import Language.LSP.VFS (virtualFileText)
import Outputable
    ( nest,
      ppr,
      showSDoc,
      text,
      ($$),
      (<+>),
    )
import System.FilePath (takeFileName)
import System.IO (hClose)
import UnliftIO.Temporary (withSystemTempFile)
import Util (OverridingBool (Never))
import Development.IDE.Core.PositionMapping (toCurrentRange)
import qualified Data.DList as DL
import Control.Lens ((^.), _1, (%~), (<&>), _3)
import Language.LSP.Types.Lens (line, end)
import CmdLineParser
import qualified Development.IDE.GHC.Compat as SrcLoc
import Control.Exception (try)

{- | Code Lens provider
 NOTE: Invoked every time the document is modified, not just when the document is saved.
-}
codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLens :: PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLens IdeState
st PluginId
plId CodeLensParams{_textDocument} =
    let dbg :: a1 -> a2 -> m ()
dbg = IdeState -> a1 -> a2 -> m ()
forall (m :: * -> *) a1 a2.
(HasCallStack, MonadIO m, Show a1, Show a2) =>
IdeState -> a1 -> a2 -> m ()
logWith IdeState
st
        perf :: a1 -> m b -> m b
perf = (a1 -> String -> m ()) -> a1 -> m b -> m b
forall (m :: * -> *) t a b.
MonadIO m =>
(t -> String -> m a) -> t -> m b -> m b
timed a1 -> String -> m ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg
     in String
-> LspT Config IO (Either ResponseError (List CodeLens))
-> LspT Config IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"codeLens" (LspT Config IO (Either ResponseError (List CodeLens))
 -> LspT Config IO (Either ResponseError (List CodeLens)))
-> LspT Config IO (Either ResponseError (List CodeLens))
-> LspT Config IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$
            ExceptT String (LspT Config IO) (List CodeLens)
-> LspT Config IO (Either ResponseError (List CodeLens))
forall (f :: * -> *) c.
Functor f =>
ExceptT String f c -> f (Either ResponseError c)
response (ExceptT String (LspT Config IO) (List CodeLens)
 -> LspT Config IO (Either ResponseError (List CodeLens)))
-> ExceptT String (LspT Config IO) (List CodeLens)
-> LspT Config IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ do
                let TextDocumentIdentifier Uri
uri = TextDocumentIdentifier
_textDocument
                String
fp <- String -> Maybe String -> ExceptT String (LspT Config IO) String
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" (Maybe String -> ExceptT String (LspT Config IO) String)
-> Maybe String -> ExceptT String (LspT Config IO) String
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' Uri
uri
                let nfp :: NormalizedFilePath
nfp = String -> NormalizedFilePath
toNormalizedFilePath' String
fp
                    isLHS :: Bool
isLHS = String -> Bool
isLiterate String
fp
                String -> String -> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"fp" String
fp
                (ParsedModule{[String]
ApiAnns
ModSummary
ParsedSource
pm_mod_summary :: ParsedModule -> ModSummary
pm_parsed_source :: ParsedModule -> ParsedSource
pm_extra_src_files :: ParsedModule -> [String]
pm_annotations :: ParsedModule -> ApiAnns
pm_annotations :: ApiAnns
pm_extra_src_files :: [String]
pm_parsed_source :: ParsedSource
pm_mod_summary :: ModSummary
..}, PositionMapping
posMap) <- IO (ParsedModule, PositionMapping)
-> ExceptT String (LspT Config IO) (ParsedModule, PositionMapping)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ParsedModule, PositionMapping)
 -> ExceptT String (LspT Config IO) (ParsedModule, PositionMapping))
-> IO (ParsedModule, PositionMapping)
-> ExceptT String (LspT Config IO) (ParsedModule, PositionMapping)
forall a b. (a -> b) -> a -> b
$
                    String
-> IdeState
-> Action (ParsedModule, PositionMapping)
-> IO (ParsedModule, PositionMapping)
forall a. String -> IdeState -> Action a -> IO a
runAction String
"parsed" IdeState
st (Action (ParsedModule, PositionMapping)
 -> IO (ParsedModule, PositionMapping))
-> Action (ParsedModule, PositionMapping)
-> IO (ParsedModule, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetParsedModuleWithComments
-> NormalizedFilePath -> Action (ParsedModule, PositionMapping)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
                let comments :: Comments
comments = ([GenLocated SrcSpan AnnotationComment] -> Comments)
-> Map SrcSpan [GenLocated SrcSpan AnnotationComment] -> Comments
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                        ( (GenLocated SrcSpan AnnotationComment -> Comments)
-> [GenLocated SrcSpan AnnotationComment] -> Comments
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((GenLocated SrcSpan AnnotationComment -> Comments)
 -> [GenLocated SrcSpan AnnotationComment] -> Comments)
-> (GenLocated SrcSpan AnnotationComment -> Comments)
-> [GenLocated SrcSpan AnnotationComment]
-> Comments
forall a b. (a -> b) -> a -> b
$ \case
                            L (RealSrcSpan RealSrcSpan
real) AnnotationComment
bdy
                                | FastString -> String
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
real) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==
                                    NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
                                , let ran0 :: Range
ran0 = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
real
                                , Just Range
curRan <- PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
posMap Range
ran0
                                ->

                                    -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
                                    -- we can concentrate on these two
                                    case AnnotationComment
bdy of
                                        AnnLineComment String
cmt ->
                                            Comments
forall a. Monoid a => a
mempty { lineComments :: Map Range RawLineComment
lineComments = Range -> RawLineComment -> Map Range RawLineComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (String -> RawLineComment
RawLineComment String
cmt) }
                                        AnnBlockComment String
cmt ->
                                            Comments
forall a. Monoid a => a
mempty { blockComments :: Map Range RawBlockComment
blockComments = Range -> RawBlockComment -> Map Range RawBlockComment
forall k a. k -> a -> Map k a
Map.singleton Range
curRan (RawBlockComment -> Map Range RawBlockComment)
-> RawBlockComment -> Map Range RawBlockComment
forall a b. (a -> b) -> a -> b
$ String -> RawBlockComment
RawBlockComment String
cmt }
                                        AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
                            GenLocated SrcSpan AnnotationComment
_ -> Comments
forall a. Monoid a => a
mempty
                        )
                        (Map SrcSpan [GenLocated SrcSpan AnnotationComment] -> Comments)
-> Map SrcSpan [GenLocated SrcSpan AnnotationComment] -> Comments
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Map SrcSpan [GenLocated SrcSpan AnnotationComment]
forall a b. (a, b) -> b
snd ApiAnns
pm_annotations
                String -> String -> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"excluded comments" (String -> ExceptT String (LspT Config IO) ())
-> String -> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, AnnotationComment)] -> String
forall a. Show a => a -> String
show ([(SrcSpan, AnnotationComment)] -> String)
-> [(SrcSpan, AnnotationComment)] -> String
forall a b. (a -> b) -> a -> b
$  DList (SrcSpan, AnnotationComment)
-> [(SrcSpan, AnnotationComment)]
forall a. DList a -> [a]
DL.toList (DList (SrcSpan, AnnotationComment)
 -> [(SrcSpan, AnnotationComment)])
-> DList (SrcSpan, AnnotationComment)
-> [(SrcSpan, AnnotationComment)]
forall a b. (a -> b) -> a -> b
$
                    ([GenLocated SrcSpan AnnotationComment]
 -> DList (SrcSpan, AnnotationComment))
-> Map SrcSpan [GenLocated SrcSpan AnnotationComment]
-> DList (SrcSpan, AnnotationComment)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                    ((GenLocated SrcSpan AnnotationComment
 -> DList (SrcSpan, AnnotationComment))
-> [GenLocated SrcSpan AnnotationComment]
-> DList (SrcSpan, AnnotationComment)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((GenLocated SrcSpan AnnotationComment
  -> DList (SrcSpan, AnnotationComment))
 -> [GenLocated SrcSpan AnnotationComment]
 -> DList (SrcSpan, AnnotationComment))
-> (GenLocated SrcSpan AnnotationComment
    -> DList (SrcSpan, AnnotationComment))
-> [GenLocated SrcSpan AnnotationComment]
-> DList (SrcSpan, AnnotationComment)
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
a AnnotationComment
b) ->
                        case AnnotationComment
b of
                            AnnLineComment{} -> DList (SrcSpan, AnnotationComment)
forall a. Monoid a => a
mempty
                            AnnBlockComment{} -> DList (SrcSpan, AnnotationComment)
forall a. Monoid a => a
mempty
                            AnnotationComment
_ -> (SrcSpan, AnnotationComment) -> DList (SrcSpan, AnnotationComment)
forall a. a -> DList a
DL.singleton (SrcSpan
a, AnnotationComment
b)
                    )
                    (Map SrcSpan [GenLocated SrcSpan AnnotationComment]
 -> DList (SrcSpan, AnnotationComment))
-> Map SrcSpan [GenLocated SrcSpan AnnotationComment]
-> DList (SrcSpan, AnnotationComment)
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Map SrcSpan [GenLocated SrcSpan AnnotationComment]
forall a b. (a, b) -> b
snd ApiAnns
pm_annotations
                String -> String -> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"comments" (String -> ExceptT String (LspT Config IO) ())
-> String -> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$ Comments -> String
forall a. Show a => a -> String
show Comments
comments

                -- Extract tests from source code
                let Sections{[Section]
setupSections :: Sections -> [Section]
nonSetupSections :: Sections -> [Section]
setupSections :: [Section]
nonSetupSections :: [Section]
..} = Bool -> Comments -> Sections
commentsToSections Bool
isLHS Comments
comments
                    tests :: [(Section, EvalId, Test)]
tests = [Section] -> [(Section, EvalId, Test)]
testsBySection [Section]
nonSetupSections
                    cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
evalCommandName Text
"Evaluate=..." ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [])
                let lenses :: [CodeLens]
lenses =
                        [ Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
testRange (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cmd') Maybe Value
forall a. Maybe a
Nothing
                        | (Section
section, EvalId
ident, Test
test) <- [(Section, EvalId, Test)]
tests
                        , let (Range
testRange, Range
resultRange) = Test -> (Range, Range)
testRanges Test
test
                              args :: EvalParams
args = [Section] -> TextDocumentIdentifier -> EvalId -> EvalParams
EvalParams ([Section]
setupSections [Section] -> [Section] -> [Section]
forall a. [a] -> [a] -> [a]
++ [Section
section]) TextDocumentIdentifier
_textDocument EvalId
ident
                              cmd' :: Command
cmd' =
                                (Command
cmd :: Command)
                                    { $sel:_arguments:Command :: Maybe (List Value)
_arguments = List Value -> Maybe (List Value)
forall a. a -> Maybe a
Just ([Value] -> List Value
forall a. [a] -> List a
List [EvalParams -> Value
forall a. ToJSON a => a -> Value
toJSON EvalParams
args])
                                    , $sel:_title:Command :: Text
_title =
                                        if Range -> Bool
trivial Range
resultRange
                                            then Text
"Evaluate..."
                                            else Text
"Refresh..."
                                    }
                        ]

                String
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"tests" (ExceptT String (LspT Config IO) ()
 -> ExceptT String (LspT Config IO) ())
-> ExceptT String (LspT Config IO) ()
-> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$
                    String -> String -> ExceptT String (LspT Config IO) ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"Tests" (String -> ExceptT String (LspT Config IO) ())
-> String -> ExceptT String (LspT Config IO) ()
forall a b. (a -> b) -> a -> b
$
                        [String] -> String
unwords
                            [ EvalId -> String
forall a. Show a => a -> String
show ([(Section, EvalId, Test)] -> EvalId
forall (t :: * -> *) a. Foldable t => t a -> EvalId
length [(Section, EvalId, Test)]
tests)
                            , String
"tests in"
                            , EvalId -> String
forall a. Show a => a -> String
show ([Section] -> EvalId
forall (t :: * -> *) a. Foldable t => t a -> EvalId
length [Section]
nonSetupSections)
                            , String
"sections"
                            , EvalId -> String
forall a. Show a => a -> String
show ([Section] -> EvalId
forall (t :: * -> *) a. Foldable t => t a -> EvalId
length [Section]
setupSections)
                            , String
"setups"
                            , EvalId -> String
forall a. Show a => a -> String
show ([CodeLens] -> EvalId
forall (t :: * -> *) a. Foldable t => t a -> EvalId
length [CodeLens]
lenses)
                            , String
"lenses."
                            ]

                List CodeLens -> ExceptT String (LspT Config IO) (List CodeLens)
forall (m :: * -> *) a. Monad m => a -> m a
return (List CodeLens -> ExceptT String (LspT Config IO) (List CodeLens))
-> List CodeLens -> ExceptT String (LspT Config IO) (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List [CodeLens]
lenses
  where
    trivial :: Range -> Bool
trivial (Range Position
p Position
p') = Position
p Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
p'

evalCommandName :: CommandId
evalCommandName :: CommandId
evalCommandName = CommandId
"evalCommand"

evalCommand :: PluginCommand IdeState
evalCommand :: PluginCommand IdeState
evalCommand = CommandId
-> Text
-> CommandFunction IdeState EvalParams
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
evalCommandName Text
"evaluate" CommandFunction IdeState EvalParams
runEvalCmd

type EvalId = Int

runEvalCmd :: CommandFunction IdeState EvalParams
runEvalCmd :: CommandFunction IdeState EvalParams
runEvalCmd IdeState
st EvalParams{EvalId
[Section]
TextDocumentIdentifier
evalId :: EvalParams -> EvalId
module_ :: EvalParams -> TextDocumentIdentifier
sections :: EvalParams -> [Section]
evalId :: EvalId
module_ :: TextDocumentIdentifier
sections :: [Section]
..} =
    let dbg :: a1 -> a2 -> m ()
dbg = IdeState -> a1 -> a2 -> m ()
forall (m :: * -> *) a1 a2.
(HasCallStack, MonadIO m, Show a1, Show a2) =>
IdeState -> a1 -> a2 -> m ()
logWith IdeState
st
        perf :: a1 -> m b -> m b
perf = (a1 -> String -> m ()) -> a1 -> m b -> m b
forall (m :: * -> *) t a b.
MonadIO m =>
(t -> String -> m a) -> t -> m b -> m b
timed a1 -> String -> m ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg
        cmd :: ExceptT String (LspM c) WorkspaceEdit
        cmd :: ExceptT String (LspM c) WorkspaceEdit
cmd = do
            let tests :: [(Section, Test)]
tests = ((Section, EvalId, Test) -> (Section, Test))
-> [(Section, EvalId, Test)] -> [(Section, Test)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Section
a,EvalId
_,Test
b) -> (Section
a,Test
b)) ([(Section, EvalId, Test)] -> [(Section, Test)])
-> [(Section, EvalId, Test)] -> [(Section, Test)]
forall a b. (a -> b) -> a -> b
$ [Section] -> [(Section, EvalId, Test)]
testsBySection [Section]
sections

            let TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} = TextDocumentIdentifier
module_
            String
fp <- String -> Maybe String -> ExceptT String (LspM c) String
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" (Maybe String -> ExceptT String (LspM c) String)
-> Maybe String -> ExceptT String (LspM c) String
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' Uri
_uri
            let nfp :: NormalizedFilePath
nfp = String -> NormalizedFilePath
toNormalizedFilePath' String
fp
            Text
mdlText <- Uri -> ExceptT String (LspM c) Text
forall e c (m :: * -> *).
(IsString e, MonadLsp c m) =>
Uri -> ExceptT e m Text
moduleText Uri
_uri

            HscEnv
session <- IdeState -> NormalizedFilePath -> ExceptT String (LspM c) HscEnv
forall (m :: * -> *).
MonadIO m =>
IdeState -> NormalizedFilePath -> m HscEnv
runGetSession IdeState
st NormalizedFilePath
nfp

            (ModSummary
ms, [LImportDecl GhcPs]
_) <-
                IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String (LspM c) (ModSummary, [LImportDecl GhcPs])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModSummary, [LImportDecl GhcPs])
 -> ExceptT String (LspM c) (ModSummary, [LImportDecl GhcPs]))
-> IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String (LspM c) (ModSummary, [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$
                    String
-> IdeState
-> Action (ModSummary, [LImportDecl GhcPs])
-> IO (ModSummary, [LImportDecl GhcPs])
forall a. String -> IdeState -> Action a -> IO a
runAction String
"runEvalCmd.getModSummary" IdeState
st (Action (ModSummary, [LImportDecl GhcPs])
 -> IO (ModSummary, [LImportDecl GhcPs]))
-> Action (ModSummary, [LImportDecl GhcPs])
-> IO (ModSummary, [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$
                        GetModSummary
-> NormalizedFilePath -> Action (ModSummary, [LImportDecl GhcPs])
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
nfp

            UTCTime
now <- IO UTCTime -> ExceptT String (LspM c) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

            let modName :: ModuleName
modName = Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms
                thisModuleTarget :: Target
thisModuleTarget =
                    TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target
                        (String -> Maybe Phase -> TargetId
TargetFile String
fp Maybe Phase
forall a. Maybe a
Nothing)
                        Bool
False
                        ((InputFileBuffer, UTCTime) -> Maybe (InputFileBuffer, UTCTime)
forall a. a -> Maybe a
Just (Text -> InputFileBuffer
textToStringBuffer Text
mdlText, UTCTime
now))

            -- Setup environment for evaluation
            HscEnv
hscEnv' <- LspM c (Either String HscEnv) -> ExceptT String (LspM c) HscEnv
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LspM c (Either String HscEnv) -> ExceptT String (LspM c) HscEnv)
-> LspM c (Either String HscEnv) -> ExceptT String (LspM c) HscEnv
forall a b. (a -> b) -> a -> b
$ (Either String (Either String HscEnv) -> Either String HscEnv)
-> LspM c (Either String (Either String HscEnv))
-> LspM c (Either String HscEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (Either String HscEnv) -> Either String HscEnv
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (LspM c (Either String (Either String HscEnv))
 -> LspM c (Either String HscEnv))
-> LspM c (Either String (Either String HscEnv))
-> LspM c (Either String HscEnv)
forall a b. (a -> b) -> a -> b
$ String
-> (String
    -> Handle -> LspM c (Either String (Either String HscEnv)))
-> LspM c (Either String (Either String HscEnv))
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String -> String
takeFileName String
fp) ((String
  -> Handle -> LspM c (Either String (Either String HscEnv)))
 -> LspM c (Either String (Either String HscEnv)))
-> (String
    -> Handle -> LspM c (Either String (Either String HscEnv)))
-> LspM c (Either String (Either String HscEnv))
forall a b. (a -> b) -> a -> b
$ \String
logFilename Handle
logHandle -> IO (Either String (Either String HscEnv))
-> LspM c (Either String (Either String HscEnv))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Either String HscEnv))
 -> LspM c (Either String (Either String HscEnv)))
-> (Ghc (Either String HscEnv)
    -> IO (Either String (Either String HscEnv)))
-> Ghc (Either String HscEnv)
-> LspM c (Either String (Either String HscEnv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either String HscEnv)
-> IO (Either String (Either String HscEnv))
forall (m :: * -> *) b.
ExceptionMonad m =>
m b -> m (Either String b)
gStrictTry (IO (Either String HscEnv)
 -> IO (Either String (Either String HscEnv)))
-> (Ghc (Either String HscEnv) -> IO (Either String HscEnv))
-> Ghc (Either String HscEnv)
-> IO (Either String (Either String HscEnv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Ghc (Either String HscEnv) -> IO (Either String HscEnv)
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
session (Ghc (Either String HscEnv)
 -> LspM c (Either String (Either String HscEnv)))
-> Ghc (Either String HscEnv)
-> LspM c (Either String (Either String HscEnv))
forall a b. (a -> b) -> a -> b
$ do
                HscEnv
env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

                -- Install the module pragmas and options
                DynFlags
df <- IO DynFlags -> Ghc DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> Ghc DynFlags) -> IO DynFlags -> Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> IO DynFlags
setupDynFlagsForGHCiLike HscEnv
env (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms

                -- Restore the original import paths
                let impPaths :: [String]
impPaths = DynFlags -> [String]
importPaths (DynFlags -> [String]) -> DynFlags -> [String]
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
env
                DynFlags
df <- DynFlags -> Ghc DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
df{importPaths :: [String]
importPaths = [String]
impPaths}

                -- Set the modified flags in the session
                [InstalledUnitId]
_lp <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df

                -- property tests need QuickCheck
                Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Section, Test)] -> Bool
needsQuickCheck [(Section, Test)]
tests) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Ghc (Either String DynFlags) -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc (Either String DynFlags) -> Ghc ())
-> Ghc (Either String DynFlags) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [String] -> Ghc (Either String DynFlags)
addPackages [String
"QuickCheck"]
                String -> Bool -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"QUICKCHECK NEEDS" (Bool -> Ghc ()) -> Bool -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [(Section, Test)] -> Bool
needsQuickCheck [(Section, Test)]
tests
                String -> Bool -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"QUICKCHECK HAS" (Bool -> Ghc ()) -> Bool -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool
hasQuickCheck DynFlags
df

                -- copy the package state to the interactive DynFlags
                DynFlags
idflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDynFlags
                DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
                DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags (DynFlags -> Ghc ()) -> DynFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$
                    ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> Extension -> DynFlags
xopt_set DynFlags
idflags [Extension]
evalExtensions)
                        { pkgState :: PackageState
pkgState =
                            DynFlags -> PackageState
pkgState
                                DynFlags
df
                        , pkgDatabase :: Maybe [(String, [PackageConfig])]
pkgDatabase =
                            DynFlags -> Maybe [(String, [PackageConfig])]
pkgDatabase
                                DynFlags
df
                        , packageFlags :: [PackageFlag]
packageFlags =
                            DynFlags -> [PackageFlag]
packageFlags
                                DynFlags
df
                        , useColor :: OverridingBool
useColor = OverridingBool
Never
                        , canUseColor :: Bool
canUseColor = Bool
False
                        }

                -- set up a custom log action
                LogAction -> Ghc ()
forall (m :: * -> *). GhcMonad m => LogAction -> m ()
setLogAction (LogAction -> Ghc ()) -> LogAction -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \DynFlags
_df WarnReason
_wr Severity
_sev SrcSpan
_span PprStyle
_style MsgDoc
_doc ->
                    DynFlags -> Handle -> MsgDoc -> PprStyle -> IO ()
defaultLogActionHPutStrDoc DynFlags
_df Handle
logHandle MsgDoc
_doc PprStyle
_style

                -- Load the module with its current content (as the saved module might not be up to date)
                -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8
                -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066
                -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile
                Either String ()
eSetTarget <- Ghc () -> Ghc (Either String ())
forall (m :: * -> *) b.
ExceptionMonad m =>
m b -> m (Either String b)
gStrictTry (Ghc () -> Ghc (Either String ()))
-> Ghc () -> Ghc (Either String ())
forall a b. (a -> b) -> a -> b
$ [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target
thisModuleTarget]
                String -> Either String () -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"setTarget" Either String ()
eSetTarget

                -- load the module in the interactive environment
                SuccessFlag
loadResult <- String -> Ghc SuccessFlag -> Ghc SuccessFlag
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"loadModule" (Ghc SuccessFlag -> Ghc SuccessFlag)
-> Ghc SuccessFlag -> Ghc SuccessFlag
forall a b. (a -> b) -> a -> b
$ LoadHowMuch -> Ghc SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets
                String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"LOAD RESULT" (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ SuccessFlag -> String
forall a. Outputable a => a -> String
asS SuccessFlag
loadResult
                case SuccessFlag
loadResult of
                    SuccessFlag
Failed -> IO (Either String HscEnv) -> Ghc (Either String HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String HscEnv) -> Ghc (Either String HscEnv))
-> IO (Either String HscEnv) -> Ghc (Either String HscEnv)
forall a b. (a -> b) -> a -> b
$ do
                        Handle -> IO ()
hClose Handle
logHandle
                        String
err <- String -> IO String
readFile String
logFilename
                        String -> String -> IO ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"load ERR" String
err
                        Either String HscEnv -> IO (Either String HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String HscEnv -> IO (Either String HscEnv))
-> Either String HscEnv -> IO (Either String HscEnv)
forall a b. (a -> b) -> a -> b
$ String -> Either String HscEnv
forall a b. a -> Either a b
Left String
err
                    SuccessFlag
Succeeded -> do
                        -- Evaluation takes place 'inside' the module
                        [InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [ModuleName -> InteractiveImport
IIModule ModuleName
modName]
                        HscEnv -> Either String HscEnv
forall a b. b -> Either a b
Right (HscEnv -> Either String HscEnv)
-> Ghc HscEnv -> Ghc (Either String HscEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

            [TextEdit]
edits <-
                String
-> ExceptT String (LspM c) [TextEdit]
-> ExceptT String (LspM c) [TextEdit]
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"edits" (ExceptT String (LspM c) [TextEdit]
 -> ExceptT String (LspM c) [TextEdit])
-> ExceptT String (LspM c) [TextEdit]
-> ExceptT String (LspM c) [TextEdit]
forall a b. (a -> b) -> a -> b
$
                    IO [TextEdit] -> ExceptT String (LspM c) [TextEdit]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TextEdit] -> ExceptT String (LspM c) [TextEdit])
-> IO [TextEdit] -> ExceptT String (LspM c) [TextEdit]
forall a b. (a -> b) -> a -> b
$
                        HscEnv -> Ghc [TextEdit] -> IO [TextEdit]
forall b. HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
hscEnv' (Ghc [TextEdit] -> IO [TextEdit])
-> Ghc [TextEdit] -> IO [TextEdit]
forall a b. (a -> b) -> a -> b
$
                            TEnv -> [(Section, Test)] -> Ghc [TextEdit]
runTests
                                (IdeState
st, String
fp)
                                [(Section, Test)]
tests

            let workspaceEditsMap :: HashMap Uri (List TextEdit)
workspaceEditsMap = [(Uri, List TextEdit)] -> HashMap Uri (List TextEdit)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Uri
_uri, [TextEdit] -> List TextEdit
forall a. [a] -> List a
List ([TextEdit] -> List TextEdit) -> [TextEdit] -> List TextEdit
forall a b. (a -> b) -> a -> b
$ Text -> [TextEdit] -> [TextEdit]
addFinalReturn Text
mdlText [TextEdit]
edits)]
            let workspaceEdits :: WorkspaceEdit
workspaceEdits = Maybe (HashMap Uri (List TextEdit))
-> Maybe (List DocumentChange) -> WorkspaceEdit
WorkspaceEdit (HashMap Uri (List TextEdit) -> Maybe (HashMap Uri (List TextEdit))
forall a. a -> Maybe a
Just HashMap Uri (List TextEdit)
workspaceEditsMap) Maybe (List DocumentChange)
forall a. Maybe a
Nothing

            WorkspaceEdit -> ExceptT String (LspM c) WorkspaceEdit
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceEdit
workspaceEdits
     in String
-> LspT Config IO (Either ResponseError Value)
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"evalCmd" (LspT Config IO (Either ResponseError Value)
 -> LspT Config IO (Either ResponseError Value))
-> LspT Config IO (Either ResponseError Value)
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$
            Text
-> ProgressCancellable
-> LspT Config IO (Either ResponseError Value)
-> LspT Config IO (Either ResponseError Value)
forall c (m :: * -> *) a.
MonadLsp c m =>
Text -> ProgressCancellable -> m a -> m a
withIndefiniteProgress Text
"Evaluating" ProgressCancellable
Cancellable (LspT Config IO (Either ResponseError Value)
 -> LspT Config IO (Either ResponseError Value))
-> LspT Config IO (Either ResponseError Value)
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$
                ExceptT String (LspT Config IO) WorkspaceEdit
-> LspT Config IO (Either ResponseError Value)
forall c.
ExceptT String (LspM c) WorkspaceEdit
-> LspM c (Either ResponseError Value)
response' ExceptT String (LspT Config IO) WorkspaceEdit
forall c. ExceptT String (LspM c) WorkspaceEdit
cmd

addFinalReturn :: Text -> [TextEdit] -> [TextEdit]
addFinalReturn :: Text -> [TextEdit] -> [TextEdit]
addFinalReturn Text
mdlText [TextEdit]
edits
    | Bool -> Bool
not ([TextEdit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TextEdit]
edits) Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
mdlText) Bool -> Bool -> Bool
&& Text -> Char
T.last Text
mdlText Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' =
        Text -> TextEdit
finalReturn Text
mdlText TextEdit -> [TextEdit] -> [TextEdit]
forall a. a -> [a] -> [a]
: [TextEdit]
edits
    | Bool
otherwise = [TextEdit]
edits

finalReturn :: Text -> TextEdit
finalReturn :: Text -> TextEdit
finalReturn Text
txt =
    let ls :: [Text]
ls = Text -> [Text]
T.lines Text
txt
        l :: EvalId
l = [Text] -> EvalId
forall (t :: * -> *) a. Foldable t => t a -> EvalId
length [Text]
ls EvalId -> EvalId -> EvalId
forall a. Num a => a -> a -> a
-EvalId
1
        c :: EvalId
c = Text -> EvalId
T.length (Text -> EvalId) -> ([Text] -> Text) -> [Text] -> EvalId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
last ([Text] -> EvalId) -> [Text] -> EvalId
forall a b. (a -> b) -> a -> b
$ [Text]
ls
        p :: Position
p = EvalId -> EvalId -> Position
Position EvalId
l EvalId
c
     in Range -> Text -> TextEdit
TextEdit (Position -> Position -> Range
Range Position
p Position
p) Text
"\n"

moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text
moduleText :: Uri -> ExceptT e m Text
moduleText Uri
uri =
    e -> m (Maybe Text) -> ExceptT e m Text
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM e
"mdlText" (m (Maybe Text) -> ExceptT e m Text)
-> m (Maybe Text) -> ExceptT e m Text
forall a b. (a -> b) -> a -> b
$
      (VirtualFile -> Text
virtualFileText (VirtualFile -> Text) -> Maybe VirtualFile -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (Maybe VirtualFile -> Maybe Text)
-> m (Maybe VirtualFile) -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormalizedUri -> m (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile
              (Uri -> NormalizedUri
toNormalizedUri Uri
uri)

testsBySection :: [Section] -> [(Section, EvalId, Test)]
testsBySection :: [Section] -> [(Section, EvalId, Test)]
testsBySection [Section]
sections =
    [(Section
section, EvalId
ident, Test
test)
    | (EvalId
ident, Section
section) <- [EvalId] -> [Section] -> [(EvalId, Section)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EvalId
0..] [Section]
sections
    , Test
test <- Section -> [Test]
sectionTests Section
section
    ]

type TEnv = (IdeState, String)

runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit]
runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit]
runTests e :: TEnv
e@(IdeState
_st, String
_) [(Section, Test)]
tests = do
    DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDynFlags
    Ghc ()
evalSetup
    Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
hasQuickCheck DynFlags
df Bool -> Bool -> Bool
&& [(Section, Test)] -> Bool
needsQuickCheck [(Section, Test)]
tests) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Ghc [Text] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [Text] -> Ghc ()) -> Ghc [Text] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ TEnv -> DynFlags -> [Statement] -> Ghc [Text]
evals TEnv
e DynFlags
df [Statement]
propSetup

    ((Section, Test) -> Ghc TextEdit)
-> [(Section, Test)] -> Ghc [TextEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit
processTest TEnv
e DynFlags
df) [(Section, Test)]
tests
  where
    processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit
    processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit
processTest e :: TEnv
e@(IdeState
st, String
fp) DynFlags
df (Section
section, Test
test) = do
        let dbg :: a1 -> a2 -> m ()
dbg = IdeState -> a1 -> a2 -> m ()
forall (m :: * -> *) a1 a2.
(HasCallStack, MonadIO m, Show a1, Show a2) =>
IdeState -> a1 -> a2 -> m ()
logWith IdeState
st
        let pad :: Text -> Text
pad = Text -> Text -> Text
pad_ (Text -> Text -> Text) -> Text -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (if String -> Bool
isLiterate String
fp then (Text
"> " Text -> Text -> Text
`T.append`) else Text -> Text
forall a. a -> a
id) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Format -> Text
forall p. IsString p => Format -> p
padPrefix (Section -> Format
sectionFormat Section
section)

        [Text]
rs <- TEnv -> DynFlags -> Test -> Ghc [Text]
runTest TEnv
e DynFlags
df Test
test
        String -> [Text] -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"TEST RESULTS" [Text]
rs

        let checkedResult :: [Text]
checkedResult = (Section, Test) -> [Text] -> [Text]
testCheck (Section
section, Test
test) [Text]
rs

        let edit :: TextEdit
edit = Format -> Test -> [Text] -> TextEdit
asEdit (Section -> Format
sectionFormat Section
section) Test
test ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
pad [Text]
checkedResult)
        String -> TextEdit -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"TEST EDIT" TextEdit
edit
        TextEdit -> Ghc TextEdit
forall (m :: * -> *) a. Monad m => a -> m a
return TextEdit
edit

    -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text]
    runTest :: TEnv -> DynFlags -> Test -> Ghc [Text]
runTest TEnv
_ DynFlags
df Test
test
        | Bool -> Bool
not (DynFlags -> Bool
hasQuickCheck DynFlags
df) Bool -> Bool -> Bool
&& Test -> Bool
isProperty Test
test =
            [Text] -> Ghc [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Ghc [Text]) -> [Text] -> Ghc [Text]
forall a b. (a -> b) -> a -> b
$
                String -> [Text]
singleLine
                    String
"Add QuickCheck to your cabal dependencies to run this test."
    runTest TEnv
e DynFlags
df Test
test = TEnv -> DynFlags -> [Statement] -> Ghc [Text]
evals TEnv
e DynFlags
df (Test -> [Statement]
asStatements Test
test)

asEdit :: Format -> Test -> [Text] -> TextEdit
asEdit :: Format -> Test -> [Text] -> TextEdit
asEdit (MultiLine Range
commRange) Test
test [Text]
resultLines
    -- A test in a block comment, ending with @-\}@ without newline in-between.
    | Test -> Range
testRange Test
test Range -> Getting EvalId Range EvalId -> EvalId
forall s a. s -> Getting a s a -> a
^. (Position -> Const EvalId Position) -> Range -> Const EvalId Range
forall s a. HasEnd s a => Lens' s a
end((Position -> Const EvalId Position)
 -> Range -> Const EvalId Range)
-> ((EvalId -> Const EvalId EvalId)
    -> Position -> Const EvalId Position)
-> Getting EvalId Range EvalId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EvalId -> Const EvalId EvalId)
-> Position -> Const EvalId Position
forall s a. HasLine s a => Lens' s a
line EvalId -> EvalId -> Bool
forall a. Eq a => a -> a -> Bool
== Range
commRange Range -> Getting EvalId Range EvalId -> EvalId
forall s a. s -> Getting a s a -> a
^. (Position -> Const EvalId Position) -> Range -> Const EvalId Range
forall s a. HasEnd s a => Lens' s a
end ((Position -> Const EvalId Position)
 -> Range -> Const EvalId Range)
-> ((EvalId -> Const EvalId EvalId)
    -> Position -> Const EvalId Position)
-> Getting EvalId Range EvalId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvalId -> Const EvalId EvalId)
-> Position -> Const EvalId Position
forall s a. HasLine s a => Lens' s a
line
    =
    Range -> Text -> TextEdit
TextEdit
        (Position -> Position -> Range
Range
            (Test -> Range
testRange Test
test Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasEnd s a => Lens' s a
end)
            (Test -> Range
resultRange Test
test Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasEnd s a => Lens' s a
end)
        )
        (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ([Text]
resultLines [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"-}"]))
asEdit Format
_ Test
test [Text]
resultLines =
    Range -> Text -> TextEdit
TextEdit (Test -> Range
resultRange Test
test) ([Text] -> Text
T.unlines [Text]
resultLines)

{-
The result of evaluating a test line can be:
* a value
* nothing
* a (possibly multiline) error message

A value is returned for a correct expression.

Either a pure value:
>>> 'h' :"askell"
"haskell"

Or an 'IO a' (output on stdout/stderr is ignored):
>>> print "OK" >> return "ABC"
"ABC"

Nothing is returned for a correct directive:

>>>:set -XFlexibleInstances
>>> import Data.Maybe

Nothing is returned for a correct declaration (let..,x=, data, class)

>>> let x = 11
>>> y = 22
>>> data B = T | F
>>> class C a

Nothing is returned for an empty line:

>>>

A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code:

>>>:set -XNonExistent
Unknown extension: "NonExistent"

>>> cls C
Variable not in scope: cls :: t0 -> ()
Data constructor not in scope: C

>>> "A
lexical error in string/character literal at end of input

>>> 3 `div` 0
divide by zero

>>> error "Something went wrong\nbad times" :: E.SomeException
Something went wrong
bad times

Or for a value that does not have a Show instance and can therefore not be displayed:
>>> data V = V
>>> V
No instance for (Show V)
-}
evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]
evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]
evals (IdeState
st, String
fp) DynFlags
df [Statement]
stmts = do
    Either String [Maybe [Text]]
er <- Ghc [Maybe [Text]] -> Ghc (Either String [Maybe [Text]])
forall (m :: * -> *) b.
ExceptionMonad m =>
m b -> m (Either String b)
gStrictTry (Ghc [Maybe [Text]] -> Ghc (Either String [Maybe [Text]]))
-> Ghc [Maybe [Text]] -> Ghc (Either String [Maybe [Text]])
forall a b. (a -> b) -> a -> b
$ (Statement -> Ghc (Maybe [Text]))
-> [Statement] -> Ghc [Maybe [Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Statement -> Ghc (Maybe [Text])
eval [Statement]
stmts
    [Text] -> Ghc [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Ghc [Text]) -> [Text] -> Ghc [Text]
forall a b. (a -> b) -> a -> b
$ case Either String [Maybe [Text]]
er of
        Left String
err -> String -> [Text]
errorLines String
err
        Right [Maybe [Text]]
rs -> [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text])
-> ([Maybe [Text]] -> [[Text]]) -> [Maybe [Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Text]] -> [[Text]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Text]] -> [Text]) -> [Maybe [Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe [Text]]
rs
  where
    dbg :: a1 -> a2 -> m ()
dbg = IdeState -> a1 -> a2 -> m ()
forall (m :: * -> *) a1 a2.
(HasCallStack, MonadIO m, Show a1, Show a2) =>
IdeState -> a1 -> a2 -> m ()
logWith IdeState
st
    eval :: Statement -> Ghc (Maybe [Text])
    eval :: Statement -> Ghc (Maybe [Text])
eval (Located EvalId
l String
stmt)
        | -- GHCi flags
          Just (String -> [String]
words -> [String]
flags) <- String -> Maybe String
parseSetFlags String
stmt = do
            String -> [String] -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{:SET" [String]
flags
            DynFlags
ndf <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDynFlags
            String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"pre set" (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
showDynFlags DynFlags
ndf
            Either GhcException (DynFlags, [Located String], [Warn])
eans <-
                IO (Either GhcException (DynFlags, [Located String], [Warn]))
-> Ghc (Either GhcException (DynFlags, [Located String], [Warn]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GhcException (DynFlags, [Located String], [Warn]))
 -> Ghc (Either GhcException (DynFlags, [Located String], [Warn])))
-> IO (Either GhcException (DynFlags, [Located String], [Warn]))
-> Ghc (Either GhcException (DynFlags, [Located String], [Warn]))
forall a b. (a -> b) -> a -> b
$ forall a.
Exception GhcException =>
IO a -> IO (Either GhcException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @GhcException (IO (DynFlags, [Located String], [Warn])
 -> IO (Either GhcException (DynFlags, [Located String], [Warn])))
-> IO (DynFlags, [Located String], [Warn])
-> IO (Either GhcException (DynFlags, [Located String], [Warn]))
forall a b. (a -> b) -> a -> b
$
                DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
ndf
                ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> String -> Located String)
-> SrcSpan -> String -> Located String
forall a b. (a -> b) -> a -> b
$ FastString -> SrcSpan
UnhelpfulSpan FastString
"<interactive>") [String]
flags)
            String
-> Either GhcException (String, [Located String], [Located String])
-> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"parsed flags" (Either GhcException (String, [Located String], [Located String])
 -> Ghc ())
-> Either GhcException (String, [Located String], [Located String])
-> Ghc ()
forall a b. (a -> b) -> a -> b
$ Either GhcException (DynFlags, [Located String], [Warn])
eans
              Either GhcException (DynFlags, [Located String], [Warn])
-> ((DynFlags, [Located String], [Warn])
    -> (String, [Located String], [Located String]))
-> Either GhcException (String, [Located String], [Located String])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((DynFlags -> Identity String)
-> (DynFlags, [Located String], [Warn])
-> Identity (String, [Located String], [Warn])
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((DynFlags -> Identity String)
 -> (DynFlags, [Located String], [Warn])
 -> Identity (String, [Located String], [Warn]))
-> (DynFlags -> String)
-> (DynFlags, [Located String], [Warn])
-> (String, [Located String], [Warn])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DynFlags -> String
showDynFlags ((DynFlags, [Located String], [Warn])
 -> (String, [Located String], [Warn]))
-> ((String, [Located String], [Warn])
    -> (String, [Located String], [Located String]))
-> (DynFlags, [Located String], [Warn])
-> (String, [Located String], [Located String])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([Warn] -> Identity [Located String])
-> (String, [Located String], [Warn])
-> Identity (String, [Located String], [Located String])
forall s t a b. Field3 s t a b => Lens s t a b
_3 (([Warn] -> Identity [Located String])
 -> (String, [Located String], [Warn])
 -> Identity (String, [Located String], [Located String]))
-> ([Warn] -> [Located String])
-> (String, [Located String], [Warn])
-> (String, [Located String], [Located String])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Warn -> Located String) -> [Warn] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map Warn -> Located String
warnMsg)
            case Either GhcException (DynFlags, [Located String], [Warn])
eans of
                Left GhcException
err -> Maybe [Text] -> Ghc (Maybe [Text])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Text] -> Ghc (Maybe [Text]))
-> Maybe [Text] -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ String -> [Text]
errorLines (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ GhcException -> String
forall a. Show a => a -> String
show GhcException
err
                Right (DynFlags
df', [Located String]
ignoreds, [Warn]
warns) -> do
                    let warnings :: m [Text]
warnings = do
                            Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Warn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Warn]
warns
                            [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ String -> [Text]
errorLines (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$
                                [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                                (Warn -> String) -> [Warn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Warn -> String
prettyWarn [Warn]
warns
                        igns :: m [Text]
igns = do
                            Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Located String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
ignoreds
                            [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                [Text
"Some flags have not been recognized: "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
SrcLoc.unLoc [Located String]
ignoreds)
                                ]
                    String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"post set" (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
showDynFlags DynFlags
df'
                    [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df'
                    DynFlags
sessDyns <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
                    DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags DynFlags
sessDyns
                    Maybe [Text] -> Ghc (Maybe [Text])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Text] -> Ghc (Maybe [Text]))
-> Maybe [Text] -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ Maybe [Text]
forall (m :: * -> *). (Monad m, Alternative m) => m [Text]
warnings Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Semigroup a => a -> a -> a
<> Maybe [Text]
forall (m :: * -> *). (Monad m, Alternative m) => m [Text]
igns
        | -- A type/kind command
          Just (Text
cmd, Text
arg) <- Text -> Maybe (Text, Text)
parseGhciLikeCmd (Text -> Maybe (Text, Text)) -> Text -> Maybe (Text, Text)
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
stmt =
            Text -> Text -> Ghc (Maybe [Text])
evalGhciLikeCmd Text
cmd Text
arg
        | -- An expression
          DynFlags -> String -> Bool
isExpr DynFlags
df String
stmt =
            do
                String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{EXPR" String
stmt
                Either String String
eres <- Ghc String -> Ghc (Either String String)
forall (m :: * -> *) b.
ExceptionMonad m =>
m b -> m (Either String b)
gStrictTry (Ghc String -> Ghc (Either String String))
-> Ghc String -> Ghc (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Ghc String
forall (m :: * -> *). GhcMonad m => String -> m String
evalExpr String
stmt
                String -> Either String String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"RES ->" Either String String
eres
                let res :: [Text]
res = case Either String String
eres of
                        Left String
err -> String -> [Text]
errorLines String
err
                        Right String
rs -> [String -> Text
T.pack String
rs]
                String -> [Text] -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"EXPR} ->" [Text]
res
                Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Text] -> Ghc (Maybe [Text]))
-> ([Text] -> Maybe [Text]) -> [Text] -> Ghc (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Ghc (Maybe [Text])) -> [Text] -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ [Text]
res
        | -- A statement
          DynFlags -> String -> Bool
isStmt DynFlags
df String
stmt =
            do
                String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{STMT " String
stmt
                ExecResult
res <- String -> EvalId -> Ghc ExecResult
forall (m :: * -> *).
GhcMonad m =>
String -> EvalId -> m ExecResult
exec String
stmt EvalId
l
                Maybe [Text]
r <- case ExecResult
res of
                    ExecComplete (Left SomeException
err) Word64
_ -> Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Text] -> Ghc (Maybe [Text]))
-> (SomeException -> Maybe [Text])
-> SomeException
-> Ghc (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text])
-> (SomeException -> [Text]) -> SomeException -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Text]
errorLines (String -> [Text])
-> (SomeException -> String) -> SomeException -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show (SomeException -> Ghc (Maybe [Text]))
-> SomeException -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ SomeException
err
                    ExecComplete (Right [Name]
_) Word64
_ -> Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Text]
forall a. Maybe a
Nothing
                    ExecBreak{} ->
                        Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Text] -> Ghc (Maybe [Text]))
-> (String -> Maybe [Text]) -> String -> Ghc (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text])
-> (String -> [Text]) -> String -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Text]
singleLine (String -> Ghc (Maybe [Text])) -> String -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ String
"breakpoints are not supported"
                String -> Maybe [Text] -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"STMT} -> " Maybe [Text]
r
                Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Text]
r
        | -- An import
          DynFlags -> String -> Bool
isImport DynFlags
df String
stmt =
            do
                String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{IMPORT " String
stmt
                [InteractiveImport]
_ <- String -> Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => String -> m [InteractiveImport]
addImport String
stmt
                Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Text]
forall a. Maybe a
Nothing
        | -- A declaration
          Bool
otherwise =
            do
                String -> String -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{DECL " String
stmt
                Ghc [Name] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [Name] -> Ghc ()) -> Ghc [Name] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls String
stmt
                Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Text]
forall a. Maybe a
Nothing
    exec :: String -> EvalId -> m ExecResult
exec String
stmt EvalId
l =
        let opts :: ExecOptions
opts = ExecOptions
execOptions{execSourceFile :: String
execSourceFile = String
fp, execLineNumber :: EvalId
execLineNumber = EvalId
l}
         in String -> ExecOptions -> m ExecResult
forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
stmt ExecOptions
opts

prettyWarn :: Warn -> String
prettyWarn :: Warn -> String
prettyWarn Warn{WarnReason
Located String
warnReason :: Warn -> WarnReason
warnMsg :: Located String
warnReason :: WarnReason
warnMsg :: Warn -> Located String
..} =
    SrcSpan -> String
forall a. Outputable a => a -> String
prettyPrint (Located String -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
SrcLoc.getLoc Located String
warnMsg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": warning:\n"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Located String -> SrcSpanLess (Located String)
forall a. HasSrcSpan a => a -> SrcSpanLess a
SrcLoc.unLoc Located String
warnMsg

ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv
ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv
ghcSessionDepsDefinition HscEnvEq
env NormalizedFilePath
file = do
        let hsc :: HscEnv
hsc = HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
env
        TransitiveDependencies
deps <- GetDependencies
-> NormalizedFilePath -> Action TransitiveDependencies
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetDependencies
GetDependencies NormalizedFilePath
file
        let tdeps :: [NormalizedFilePath]
tdeps = TransitiveDependencies -> [NormalizedFilePath]
transitiveModuleDeps TransitiveDependencies
deps
        [HiFileResult]
ifaces <- GetModIface -> [NormalizedFilePath] -> Action [HiFileResult]
forall k v. IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
uses_ GetModIface
GetModIface [NormalizedFilePath]
tdeps

        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
        -- Long-term we might just want to change the order returned by GetDependencies
        let inLoadOrder :: [HomeModInfo]
inLoadOrder = [HomeModInfo] -> [HomeModInfo]
forall a. [a] -> [a]
reverse ((HiFileResult -> HomeModInfo) -> [HiFileResult] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map HiFileResult -> HomeModInfo
hirHomeMod [HiFileResult]
ifaces)

        IO HscEnv -> Action HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> Action HscEnv) -> IO HscEnv -> Action HscEnv
forall a b. (a -> b) -> a -> b
$ [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome [HomeModInfo]
inLoadOrder (HscEnv -> HscEnv) -> IO HscEnv -> IO HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModSummary] -> HscEnv -> IO HscEnv
setupFinderCache ((HiFileResult -> ModSummary) -> [HiFileResult] -> [ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map HiFileResult -> ModSummary
hirModSummary [HiFileResult]
ifaces) HscEnv
hsc

runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv
runGetSession :: IdeState -> NormalizedFilePath -> m HscEnv
runGetSession IdeState
st NormalizedFilePath
nfp = IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action HscEnv -> IO HscEnv
forall a. String -> IdeState -> Action a -> IO a
runAction String
"eval" IdeState
st (Action HscEnv -> IO HscEnv) -> Action HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ do
    -- Create a new GHC Session rather than reusing an existing one
    -- to avoid interfering with ghcide
    IdeGhcSession{String -> IO (IdeResult HscEnvEq, [String])
loadSessionFun :: IdeGhcSession -> String -> IO (IdeResult HscEnvEq, [String])
loadSessionFun :: String -> IO (IdeResult HscEnvEq, [String])
loadSessionFun} <- GhcSessionIO -> Action IdeGhcSession
forall k v. IdeRule k v => k -> Action v
useNoFile_ GhcSessionIO
GhcSessionIO
    let fp :: String
fp = NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp
    (([FileDiagnostic]
_, Maybe HscEnvEq
res),[String]
_) <- IO (IdeResult HscEnvEq, [String])
-> Action (IdeResult HscEnvEq, [String])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IdeResult HscEnvEq, [String])
 -> Action (IdeResult HscEnvEq, [String]))
-> IO (IdeResult HscEnvEq, [String])
-> Action (IdeResult HscEnvEq, [String])
forall a b. (a -> b) -> a -> b
$ String -> IO (IdeResult HscEnvEq, [String])
loadSessionFun String
fp
    let hscEnv :: HscEnvEq
hscEnv = HscEnvEq -> Maybe HscEnvEq -> HscEnvEq
forall a. a -> Maybe a -> a
fromMaybe (String -> HscEnvEq
forall a. HasCallStack => String -> a
error (String -> HscEnvEq) -> String -> HscEnvEq
forall a b. (a -> b) -> a -> b
$ String
"Unknown file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp) Maybe HscEnvEq
res
    HscEnvEq -> NormalizedFilePath -> Action HscEnv
ghcSessionDepsDefinition HscEnvEq
hscEnv NormalizedFilePath
nfp

needsQuickCheck :: [(Section, Test)] -> Bool
needsQuickCheck :: [(Section, Test)] -> Bool
needsQuickCheck = ((Section, Test) -> Bool) -> [(Section, Test)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Test -> Bool
isProperty (Test -> Bool)
-> ((Section, Test) -> Test) -> (Section, Test) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Section, Test) -> Test
forall a b. (a, b) -> b
snd)

hasQuickCheck :: DynFlags -> Bool
hasQuickCheck :: DynFlags -> Bool
hasQuickCheck DynFlags
df = DynFlags -> String -> Bool
hasPackage DynFlags
df String
"QuickCheck"

singleLine :: String -> [Text]
singleLine :: String -> [Text]
singleLine String
s = [String -> Text
T.pack String
s]

{- |
 Convert error messages to a list of text lines
 Remove unnecessary information.
-}
errorLines :: String -> [Text]
errorLines :: String -> [Text]
errorLines =
    (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
e -> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
e (Text -> Text -> Maybe Text
T.stripSuffix Text
"arising from a use of ‘asPrint’" Text
e))
        ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
        ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"CallStack" Text -> Text -> Bool
`T.isPrefixOf`))
        ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
        (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

{- |
>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])
["--2+2","--<BLANKLINE>"]
-}
pad_ :: Text -> Text -> Text
pad_ :: Text -> Text -> Text
pad_ Text
prefix = (Text
prefix Text -> Text -> Text
`T.append`) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
convertBlank

convertBlank :: Text -> Text
convertBlank :: Text -> Text
convertBlank Text
x
    | Text -> Bool
T.null Text
x = Text
"<BLANKLINE>"
    | Bool
otherwise = Text
x

padPrefix :: IsString p => Format -> p
padPrefix :: Format -> p
padPrefix Format
SingleLine = p
"-- "
padPrefix Format
_ = p
""

{- | Resulting @Text@ MUST NOT prefix each line with @--@
   Such comment-related post-process will be taken place
   solely in 'evalGhciLikeCmd'.
-}
type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)

-- Should we use some sort of trie here?
ghciLikeCommands :: [(Text, GHCiLikeCmd)]
ghciLikeCommands :: [(Text, GHCiLikeCmd)]
ghciLikeCommands =
    [(Text
"kind", Bool -> GHCiLikeCmd
doKindCmd Bool
False), (Text
"kind!", Bool -> GHCiLikeCmd
doKindCmd Bool
True), (Text
"type", GHCiLikeCmd
doTypeCmd)]

evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text])
evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text])
evalGhciLikeCmd Text
cmd Text
arg = do
    DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    case Text -> [(Text, GHCiLikeCmd)] -> Maybe GHCiLikeCmd
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
cmd [(Text, GHCiLikeCmd)]
ghciLikeCommands
        Maybe GHCiLikeCmd -> Maybe GHCiLikeCmd -> Maybe GHCiLikeCmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text, GHCiLikeCmd) -> GHCiLikeCmd
forall a b. (a, b) -> b
snd
        ((Text, GHCiLikeCmd) -> GHCiLikeCmd)
-> Maybe (Text, GHCiLikeCmd) -> Maybe GHCiLikeCmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, GHCiLikeCmd) -> Bool)
-> [(Text, GHCiLikeCmd)] -> Maybe (Text, GHCiLikeCmd)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Text -> Bool
T.isPrefixOf Text
cmd (Text -> Bool)
-> ((Text, GHCiLikeCmd) -> Text) -> (Text, GHCiLikeCmd) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, GHCiLikeCmd) -> Text
forall a b. (a, b) -> a
fst) [(Text, GHCiLikeCmd)]
ghciLikeCommands of
        Just GHCiLikeCmd
hndler ->
            (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                Text -> [Text]
T.lines
                (Maybe Text -> Maybe [Text])
-> Ghc (Maybe Text) -> Ghc (Maybe [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GHCiLikeCmd
hndler DynFlags
df Text
arg
        Maybe GHCiLikeCmd
_ -> GhciLikeCmdException -> Ghc (Maybe [Text])
forall a e. Exception e => e -> a
E.throw (GhciLikeCmdException -> Ghc (Maybe [Text]))
-> GhciLikeCmdException -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ Text -> Text -> GhciLikeCmdException
GhciLikeCmdNotImplemented Text
cmd Text
arg

doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
doKindCmd :: Bool -> GHCiLikeCmd
doKindCmd Bool
False DynFlags
df Text
arg = do
    let input :: Text
input = Text -> Text
T.strip Text
arg
    (Type
_, Type
kind) <- Bool -> String -> Ghc (Type, Type)
forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Type, Type)
typeKind Bool
False (String -> Ghc (Type, Type)) -> String -> Ghc (Type, Type)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
input
    let kindText :: MsgDoc
kindText = String -> MsgDoc
text (Text -> String
T.unpack Text
input) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
"::" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
kind
    Maybe Text -> Ghc (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Ghc (Maybe Text)) -> Maybe Text -> Ghc (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (DynFlags -> MsgDoc -> String
showSDoc DynFlags
df MsgDoc
kindText)
doKindCmd Bool
True DynFlags
df Text
arg = do
    let input :: Text
input = Text -> Text
T.strip Text
arg
    (Type
ty, Type
kind) <- Bool -> String -> Ghc (Type, Type)
forall (m :: * -> *).
GhcMonad m =>
Bool -> String -> m (Type, Type)
typeKind Bool
True (String -> Ghc (Type, Type)) -> String -> Ghc (Type, Type)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
input
    let kindDoc :: MsgDoc
kindDoc = String -> MsgDoc
text (Text -> String
T.unpack Text
input) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
"::" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
kind
        tyDoc :: MsgDoc
tyDoc = MsgDoc
"=" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty
    Maybe Text -> Ghc (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Ghc (Maybe Text)) -> Maybe Text -> Ghc (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (DynFlags -> MsgDoc -> String
showSDoc DynFlags
df (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ MsgDoc
kindDoc MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
tyDoc)

doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)
doTypeCmd :: GHCiLikeCmd
doTypeCmd DynFlags
dflags Text
arg = do
    let (TcRnExprMode
emod, Text
expr) = Text -> (TcRnExprMode, Text)
parseExprMode Text
arg
    Type
ty <- TcRnExprMode -> String -> Ghc Type
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
exprType TcRnExprMode
emod (String -> Ghc Type) -> String -> Ghc Type
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
expr
    let rawType :: Text
rawType = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty
        broken :: Bool
broken = (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
rawType
    Maybe Text -> Ghc (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Ghc (Maybe Text)) -> Maybe Text -> Ghc (Maybe Text)
forall a b. (a -> b) -> a -> b
$
        Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
            if Bool
broken
                then
                    String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                        DynFlags -> MsgDoc -> String
showSDoc DynFlags
dflags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
                            String -> MsgDoc
text (Text -> String
T.unpack Text
expr)
                                MsgDoc -> MsgDoc -> MsgDoc
$$ EvalId -> MsgDoc -> MsgDoc
nest EvalId
2 (MsgDoc
"::" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty)
                else Text
expr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rawType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

parseExprMode :: Text -> (TcRnExprMode, T.Text)
parseExprMode :: Text -> (TcRnExprMode, Text)
parseExprMode Text
rawArg = case (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
rawArg of
    (Text
"+v", Text
rest) -> (TcRnExprMode
TM_NoInst, Text -> Text
T.strip Text
rest)
    (Text
"+d", Text
rest) -> (TcRnExprMode
TM_Default, Text -> Text
T.strip Text
rest)
    (Text, Text)
_ -> (TcRnExprMode
TM_Inst, Text
rawArg)

data GhciLikeCmdException = GhciLikeCmdNotImplemented
    { GhciLikeCmdException -> Text
ghciCmdName :: Text
    , GhciLikeCmdException -> Text
ghciCmdArg :: Text
    }
    deriving (Typeable)

instance Show GhciLikeCmdException where
    showsPrec :: EvalId -> GhciLikeCmdException -> String -> String
showsPrec EvalId
_ GhciLikeCmdNotImplemented{Text
ghciCmdArg :: Text
ghciCmdName :: Text
$sel:ghciCmdArg:GhciLikeCmdNotImplemented :: GhciLikeCmdException -> Text
$sel:ghciCmdName:GhciLikeCmdNotImplemented :: GhciLikeCmdException -> Text
..} =
        String -> String -> String
showString String
"unknown command '"
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Text -> String
T.unpack Text
ghciCmdName)
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'\''

instance E.Exception GhciLikeCmdException

{-
>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1")
Just ("kind!","N + M + 1")
>>> parseGhciLikeCmd (T.pack ":kind a")
Just ("kind","a")
-}
parseGhciLikeCmd :: Text -> Maybe (Text, Text)
parseGhciLikeCmd :: Text -> Maybe (Text, Text)
parseGhciLikeCmd Text
input = do
    (Char
':', Text
rest) <- Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripStart Text
input
    (Text, Text) -> Maybe (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Text) -> Maybe (Text, Text))
-> (Text, Text) -> Maybe (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Text
T.strip ((Text, Text) -> (Text, Text)) -> (Text, Text) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
rest

setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags
setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags
setupDynFlagsForGHCiLike HscEnv
env DynFlags
dflags = do
    let dflags3 :: DynFlags
dflags3 =
            DynFlags
dflags
                { hscTarget :: HscTarget
hscTarget = HscTarget
HscInterpreted
                , ghcMode :: GhcMode
ghcMode = GhcMode
CompManager
                , ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory
                }
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags3
        dflags3a :: DynFlags
dflags3a = DynFlags -> DynFlags
updateWays (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags3{ways :: [Way]
ways = [Way]
interpWays}
        dflags3b :: DynFlags
dflags3b =
            (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags3a ([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$
                (Way -> [GeneralFlag]) -> [Way] -> [GeneralFlag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform) [Way]
interpWays
        dflags3c :: DynFlags
dflags3c =
            (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags3b ([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$
                (Way -> [GeneralFlag]) -> [Way] -> [GeneralFlag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform) [Way]
interpWays
        dflags4 :: DynFlags
dflags4 =
            DynFlags
dflags3c
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreOptimChanges
                DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreHpcChanges
                DynFlags -> GeneralFlag -> DynFlags
`gopt_unset` GeneralFlag
Opt_DiagnosticsShowCaret
    HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
env DynFlags
dflags4