{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
{-# 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,
 )
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Except (
    ExceptT (..),
    runExceptT,
 )
import Data.Aeson (
    FromJSON,
    ToJSON,
    toJSON,
 )
import Data.Char (isSpace)
import Data.Either (isRight)
import qualified Data.HashMap.Strict as Map
import Data.List (
    dropWhileEnd,
    find,
 )
import Data.Maybe (
    catMaybes,
    fromMaybe,
 )
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time (getCurrentTime)
import Data.Typeable (Typeable)
import Development.IDE (
    GetModSummary (..),
    GhcSession (..),
    HscEnvEq (envImportPaths, hscEnv),
    IdeState,
    List (List),
    NormalizedFilePath,
    Range (Range),
    Uri,
    evalGhcEnv,
    hscEnvWithImportPaths,
    runAction,
    stringBufferToByteString,
    textToStringBuffer,
    toNormalizedFilePath',
    toNormalizedUri,
    uriToFilePath',
    use_,
 )
import Development.IDE.Core.Preprocessor (
    preprocessor,
 )
import Development.IDE.GHC.Compat (HscEnv)
import DynamicLoading (initializePlugins)
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,
    setInteractiveDynFlags,
    setLogAction,
    setSessionDynFlags,
    setTargets,
    typeKind,
 )
import GHC.Generics (Generic)
import qualified GHC.LanguageExtensions.Type as LangExt
import GhcPlugins (
    DynFlags (..),
    defaultLogActionHPutStrDoc,
    gopt_set,
    gopt_unset,
    interpWays,
    targetPlatform,
    updateWays,
    wayGeneralFlags,
    wayUnsetGeneralFlags,
    xopt_set,
 )
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 (
    addExtension,
    addImport,
    addPackages,
    hasPackage,
    isExpr,
    showDynFlags,
 )
import Ide.Plugin.Eval.Parse.Option (langOptions)
import Ide.Plugin.Eval.Parse.Section (
    Section (
        sectionFormat,
        sectionTests
    ),
    allSections,
 )
import Ide.Plugin.Eval.Parse.Token (tokensFrom)
import Ide.Plugin.Eval.Types (
    Format (SingleLine),
    Loc,
    Located (Located),
    Test,
    hasTests,
    isProperty,
    splitSections,
    unLoc,
 )
import Ide.Plugin.Eval.Util (
    asS,
    gStrictTry,
    handleMaybe,
    handleMaybeM,
    isLiterate,
    logWith,
    response,
    response',
    timed,
 )
import Ide.PluginUtils (mkLspCommand)
import Ide.Types (
    CodeLensProvider,
    CommandFunction,
    CommandId,
    PluginCommand (PluginCommand),
 )
import Language.Haskell.LSP.Core (
    LspFuncs (
        getVirtualFileFunc,
        withIndefiniteProgress
    ),
    ProgressCancellable (
        Cancellable
    ),
 )
import Language.Haskell.LSP.Types (
    ApplyWorkspaceEditParams (
        ApplyWorkspaceEditParams
    ),
    CodeLens (CodeLens),
    CodeLensParams (
        CodeLensParams,
        _textDocument
    ),
    Command (_arguments, _title),
    ServerMethod (
        WorkspaceApplyEdit
    ),
    TextDocumentIdentifier (..),
    TextEdit (TextEdit),
    WorkspaceEdit (WorkspaceEdit),
 )
import Language.Haskell.LSP.VFS (virtualFileText)
import Outputable (
    nest,
    ppr,
    showSDoc,
    text,
    ($$),
    (<+>),
 )
import System.FilePath (takeFileName)
import System.IO (hClose)
import System.IO.Temp (withSystemTempFile)
import Text.Read (readMaybe)
import Util (OverridingBool (Never))

{- | Code Lens provider
 NOTE: Invoked every time the document is modified, not just when the document is saved.
-}
codeLens :: CodeLensProvider IdeState
codeLens :: CodeLensProvider IdeState
codeLens LspFuncs Config
lsp IdeState
st PluginId
plId CodeLensParams{TextDocumentIdentifier
_textDocument :: TextDocumentIdentifier
$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_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
-> IO (Either ResponseError (List CodeLens))
-> IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"codeLens" (IO (Either ResponseError (List CodeLens))
 -> IO (Either ResponseError (List CodeLens)))
-> IO (Either ResponseError (List CodeLens))
-> IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$
            ExceptT String IO (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall (f :: * -> *) c.
Functor f =>
ExceptT String f c -> f (Either ResponseError c)
response (ExceptT String IO (List CodeLens)
 -> IO (Either ResponseError (List CodeLens)))
-> ExceptT String IO (List CodeLens)
-> 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 IO String
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" (Maybe String -> ExceptT String IO String)
-> Maybe String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath' Uri
uri
                String -> String -> ExceptT String IO ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"fp" String
fp
                Text
mdlText <- LspFuncs Config -> Uri -> ExceptT String IO Text
forall e (m :: * -> *) c.
(IsString e, MonadIO m) =>
LspFuncs c -> Uri -> ExceptT e m Text
moduleText LspFuncs Config
lsp Uri
uri

                {- Normalise CPP/LHS files/custom preprocessed files.
                   Used to extract tests correctly from CPP and LHS (Bird-style).
                -}
                HscEnvEq
session :: HscEnvEq <-
                    IdeState -> NormalizedFilePath -> ExceptT String IO HscEnvEq
forall (m :: * -> *).
MonadIO m =>
IdeState -> NormalizedFilePath -> m HscEnvEq
runGetSession IdeState
st (NormalizedFilePath -> ExceptT String IO HscEnvEq)
-> NormalizedFilePath -> ExceptT String IO HscEnvEq
forall a b. (a -> b) -> a -> b
$ String -> NormalizedFilePath
toNormalizedFilePath' String
fp

                Right (StringBuffer
ppContent, DynFlags
_dflags) <-
                    String
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"preprocessor" (ExceptT
   String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
 -> ExceptT
      String IO (Either [FileDiagnostic] (StringBuffer, DynFlags)))
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall a b. (a -> b) -> a -> b
$
                        IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
 -> ExceptT
      String IO (Either [FileDiagnostic] (StringBuffer, DynFlags)))
-> IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
-> ExceptT
     String IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall a b. (a -> b) -> a -> b
$
                            ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
-> IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
 -> IO (Either [FileDiagnostic] (StringBuffer, DynFlags)))
-> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
-> IO (Either [FileDiagnostic] (StringBuffer, DynFlags))
forall a b. (a -> b) -> a -> b
$
                                HscEnv
-> String
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
preprocessor (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) String
fp (StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just (StringBuffer -> Maybe StringBuffer)
-> StringBuffer -> Maybe StringBuffer
forall a b. (a -> b) -> a -> b
$ Text -> StringBuffer
textToStringBuffer Text
mdlText)
                let text :: Text
text =
                        Bool -> Text -> Text
cleanSource (String -> Bool
isLiterate String
fp) (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
                            StringBuffer -> ByteString
stringBufferToByteString
                                StringBuffer
ppContent
                -- dbg "PREPROCESSED CONTENT" text

                -- Extract tests from source code
                let Right ([Section]
setups, [Section]
nonSetups) =
                        ([Section] -> ([Section], [Section])
splitSections ([Section] -> ([Section], [Section]))
-> ([Section] -> [Section]) -> [Section] -> ([Section], [Section])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Section -> Bool) -> [Section] -> [Section]
forall a. (a -> Bool) -> [a] -> [a]
filter Section -> Bool
hasTests ([Section] -> ([Section], [Section]))
-> Either String [Section] -> Either String ([Section], [Section])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
                            (Either String [Section] -> Either String ([Section], [Section]))
-> (Text -> Either String [Section])
-> Text
-> Either String ([Section], [Section])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tk] -> Either String [Section]
allSections
                            ([Tk] -> Either String [Section])
-> (Text -> [Tk]) -> Text -> Either String [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Tk]
tokensFrom
                            (String -> [Tk]) -> (Text -> String) -> Text -> [Tk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
                            (Text -> Either String ([Section], [Section]))
-> Text -> Either String ([Section], [Section])
forall a b. (a -> b) -> a -> b
$ Text
text
                let tests :: [(Section, Loc Test)]
tests = [Section] -> [(Section, Loc Test)]
testsBySection [Section]
nonSetups

                Command
cmd <- IO Command -> ExceptT String IO Command
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Command -> ExceptT String IO Command)
-> IO Command -> ExceptT String IO Command
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> IO 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, Loc Test
test) <- [(Section, Loc Test)]
tests
                        , let (Range
testRange, Range
resultRange) = Loc Test -> (Range, Range)
testRanges Loc Test
test
                              args :: EvalParams
args = [Section] -> TextDocumentIdentifier -> EvalParams
EvalParams ([Section]
setups [Section] -> [Section] -> [Section]
forall a. [a] -> [a] -> [a]
++ [Section
section]) TextDocumentIdentifier
_textDocument
                              cmd' :: Command
cmd' =
                                (Command
cmd :: Command)
                                    { _arguments :: 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])
                                    , _title :: Text
_title =
                                        if Range -> Bool
trivial Range
resultRange
                                            then Text
"Evaluate..."
                                            else Text
"Refresh..."
                                    }
                        ]

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

                List CodeLens -> ExceptT String IO (List CodeLens)
forall (m :: * -> *) a. Monad m => a -> m a
return (List CodeLens -> ExceptT String IO (List CodeLens))
-> List CodeLens -> ExceptT String 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

-- |Specify the test section to execute
data EvalParams = EvalParams
    { EvalParams -> [Section]
sections :: [Section]
    , EvalParams -> TextDocumentIdentifier
module_ :: !TextDocumentIdentifier
    }
    deriving (EvalParams -> EvalParams -> Bool
(EvalParams -> EvalParams -> Bool)
-> (EvalParams -> EvalParams -> Bool) -> Eq EvalParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EvalParams -> EvalParams -> Bool
$c/= :: EvalParams -> EvalParams -> Bool
== :: EvalParams -> EvalParams -> Bool
$c== :: EvalParams -> EvalParams -> Bool
Eq, Int -> EvalParams -> ShowS
[EvalParams] -> ShowS
EvalParams -> String
(Int -> EvalParams -> ShowS)
-> (EvalParams -> String)
-> ([EvalParams] -> ShowS)
-> Show EvalParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvalParams] -> ShowS
$cshowList :: [EvalParams] -> ShowS
show :: EvalParams -> String
$cshow :: EvalParams -> String
showsPrec :: Int -> EvalParams -> ShowS
$cshowsPrec :: Int -> EvalParams -> ShowS
Show, (forall x. EvalParams -> Rep EvalParams x)
-> (forall x. Rep EvalParams x -> EvalParams) -> Generic EvalParams
forall x. Rep EvalParams x -> EvalParams
forall x. EvalParams -> Rep EvalParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EvalParams x -> EvalParams
$cfrom :: forall x. EvalParams -> Rep EvalParams x
Generic, Value -> Parser [EvalParams]
Value -> Parser EvalParams
(Value -> Parser EvalParams)
-> (Value -> Parser [EvalParams]) -> FromJSON EvalParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [EvalParams]
$cparseJSONList :: Value -> Parser [EvalParams]
parseJSON :: Value -> Parser EvalParams
$cparseJSON :: Value -> Parser EvalParams
FromJSON, [EvalParams] -> Encoding
[EvalParams] -> Value
EvalParams -> Encoding
EvalParams -> Value
(EvalParams -> Value)
-> (EvalParams -> Encoding)
-> ([EvalParams] -> Value)
-> ([EvalParams] -> Encoding)
-> ToJSON EvalParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [EvalParams] -> Encoding
$ctoEncodingList :: [EvalParams] -> Encoding
toJSONList :: [EvalParams] -> Value
$ctoJSONList :: [EvalParams] -> Value
toEncoding :: EvalParams -> Encoding
$ctoEncoding :: EvalParams -> Encoding
toJSON :: EvalParams -> Value
$ctoJSON :: EvalParams -> Value
ToJSON)

runEvalCmd :: CommandFunction IdeState EvalParams
runEvalCmd :: CommandFunction IdeState EvalParams
runEvalCmd LspFuncs Config
lsp IdeState
st EvalParams{[Section]
TextDocumentIdentifier
module_ :: TextDocumentIdentifier
sections :: [Section]
$sel:module_:EvalParams :: EvalParams -> TextDocumentIdentifier
$sel:sections:EvalParams :: EvalParams -> [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 IO (ServerMethod, ApplyWorkspaceEditParams)
cmd = do
            let tests :: [(Section, Loc Test)]
tests = [Section] -> [(Section, Loc Test)]
testsBySection [Section]
sections

            let TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} = TextDocumentIdentifier
module_
            String
fp <- String -> Maybe String -> ExceptT String IO String
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe String
"uri" (Maybe String -> ExceptT String IO String)
-> Maybe String -> ExceptT String IO 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 <- LspFuncs Config -> Uri -> ExceptT String IO Text
forall e (m :: * -> *) c.
(IsString e, MonadIO m) =>
LspFuncs c -> Uri -> ExceptT e m Text
moduleText LspFuncs Config
lsp Uri
_uri

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

            (ModSummary
ms, [LImportDecl GhcPs]
_) <-
                IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String IO (ModSummary, [LImportDecl GhcPs])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModSummary, [LImportDecl GhcPs])
 -> ExceptT String IO (ModSummary, [LImportDecl GhcPs]))
-> IO (ModSummary, [LImportDecl GhcPs])
-> ExceptT String IO (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 IO 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 (StringBuffer, UTCTime) -> Target
Target
                        (String -> Maybe Phase -> TargetId
TargetFile String
fp Maybe Phase
forall a. Maybe a
Nothing)
                        Bool
False
                        ((StringBuffer, UTCTime) -> Maybe (StringBuffer, UTCTime)
forall a. a -> Maybe a
Just (Text -> StringBuffer
textToStringBuffer Text
mdlText, UTCTime
now))

            -- Setup environment for evaluation
            HscEnv
hscEnv' <- String
-> (String -> Handle -> ExceptT String IO HscEnv)
-> ExceptT String IO HscEnv
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (ShowS
takeFileName String
fp) ((String -> Handle -> ExceptT String IO HscEnv)
 -> ExceptT String IO HscEnv)
-> (String -> Handle -> ExceptT String IO HscEnv)
-> ExceptT String IO HscEnv
forall a b. (a -> b) -> a -> b
$ \String
logFilename Handle
logHandle -> IO (Either String HscEnv) -> ExceptT String IO HscEnv
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String HscEnv) -> ExceptT String IO HscEnv)
-> (Ghc (Either String HscEnv) -> IO (Either String HscEnv))
-> Ghc (Either String HscEnv)
-> ExceptT String IO HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Either String HscEnv)
-> (Either String HscEnv -> Either String HscEnv)
-> Either String (Either String HscEnv)
-> Either String HscEnv
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either String HscEnv
forall a b. a -> Either a b
Left Either String HscEnv -> Either String HscEnv
forall a. a -> a
id (Either String (Either String HscEnv) -> Either String HscEnv)
-> IO (Either String (Either String HscEnv))
-> IO (Either String HscEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO (Either String (Either String HscEnv))
 -> IO (Either String HscEnv))
-> (Ghc (Either String HscEnv)
    -> IO (Either String (Either String HscEnv)))
-> Ghc (Either String HscEnv)
-> IO (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 (HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
session) (Ghc (Either String HscEnv) -> ExceptT String IO HscEnv)
-> Ghc (Either String HscEnv) -> ExceptT String IO 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

                let impPaths :: [String]
impPaths = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe (DynFlags -> [String]
importPaths DynFlags
df) (HscEnvEq -> Maybe [String]
envImportPaths HscEnvEq
session)
                -- Restore the cradle import paths
                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, Loc Test)] -> Bool
needsQuickCheck [(Section, Loc 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, Loc Test)] -> Bool
needsQuickCheck [(Section, Loc 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 IO [TextEdit] -> ExceptT String IO [TextEdit]
forall (m :: * -> *) a1 b. (MonadIO m, Show a1) => a1 -> m b -> m b
perf String
"edits" (ExceptT String IO [TextEdit] -> ExceptT String IO [TextEdit])
-> ExceptT String IO [TextEdit] -> ExceptT String IO [TextEdit]
forall a b. (a -> b) -> a -> b
$
                    IO [TextEdit] -> ExceptT String IO [TextEdit]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TextEdit] -> ExceptT String IO [TextEdit])
-> IO [TextEdit] -> ExceptT String IO [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, Loc Test)] -> Ghc [TextEdit]
runTests
                                (IdeState
st, String
fp)
                                [(Section, Loc 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
Map.fromList [(Uri
_uri, [TextEdit] -> List TextEdit
forall a. [a] -> List a
List [TextEdit]
edits)]
            let workspaceEdits :: WorkspaceEdit
workspaceEdits = Maybe (HashMap Uri (List TextEdit))
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
WorkspaceEdit (HashMap Uri (List TextEdit) -> Maybe (HashMap Uri (List TextEdit))
forall a. a -> Maybe a
Just HashMap Uri (List TextEdit)
workspaceEditsMap) Maybe (List TextDocumentEdit)
forall a. Maybe a
Nothing

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

moduleText :: (IsString e, MonadIO m) => LspFuncs c -> Uri -> ExceptT e m Text
moduleText :: LspFuncs c -> Uri -> ExceptT e m Text
moduleText LspFuncs c
lsp 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
$
        IO (Maybe Text) -> m (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> m (Maybe Text))
-> IO (Maybe Text) -> m (Maybe 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)
-> IO (Maybe VirtualFile) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc
                    LspFuncs c
lsp
                    (Uri -> NormalizedUri
toNormalizedUri Uri
uri)

testsBySection :: [Section] -> [(Section, Loc Test)]
testsBySection :: [Section] -> [(Section, Loc Test)]
testsBySection [Section]
sections =
    [(Section
section, Loc Test
test) | Section
section <- [Section]
sections, Loc Test
test <- Section -> [Loc Test]
sectionTests Section
section]

type TEnv = (IdeState, String)

runTests :: TEnv -> [(Section, Loc Test)] -> Ghc [TextEdit]
runTests :: TEnv -> [(Section, Loc Test)] -> Ghc [TextEdit]
runTests e :: TEnv
e@(IdeState
_st, String
_) [(Section, Loc 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, Loc Test)] -> Bool
needsQuickCheck [(Section, Loc 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, Loc Test) -> Ghc TextEdit)
-> [(Section, Loc Test)] -> Ghc [TextEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TEnv -> DynFlags -> (Section, Loc Test) -> Ghc TextEdit
processTest TEnv
e DynFlags
df) [(Section, Loc Test)]
tests
  where
    processTest :: TEnv -> DynFlags -> (Section, Loc Test) -> Ghc TextEdit
    processTest :: TEnv -> DynFlags -> (Section, Loc Test) -> Ghc TextEdit
processTest e :: TEnv
e@(IdeState
st, String
fp) DynFlags
df (Section
section, Loc 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 -> Loc Test -> Ghc [Text]
runTest TEnv
e DynFlags
df Loc 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, Loc Test -> Test
forall l a. Located l a -> a
unLoc Loc Test
test) [Text]
rs

        let edit :: TextEdit
edit = Range -> Text -> TextEdit
TextEdit (Loc Test -> Range
resultRange Loc Test
test) ([Text] -> Text
T.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
pad ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [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 -> Loc Test -> Ghc [Text]
runTest TEnv
_ DynFlags
df Loc Test
test
        | Bool -> Bool
not (DynFlags -> Bool
hasQuickCheck DynFlags
df) Bool -> Bool -> Bool
&& (Test -> Bool
isProperty (Test -> Bool) -> (Loc Test -> Test) -> Loc Test -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc Test -> Test
forall l a. Located l a -> a
unLoc (Loc Test -> Bool) -> Loc Test -> Bool
forall a b. (a -> b) -> a -> b
$ Loc 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 Loc Test
test = TEnv -> DynFlags -> [Statement] -> Ghc [Text]
evals TEnv
e DynFlags
df (Loc Test -> [Statement]
asStatements Loc Test
test)

{-
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 -> f0
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 Int
l String
stmt)
        | -- A :set -XLanguageOption directive
          Either String [String] -> Bool
forall a b. Either a b -> Bool
isRight (String -> Either String [String]
langOptions String
stmt) =
            (String -> Ghc (Maybe [Text]))
-> ([Extension] -> Ghc (Maybe [Text]))
-> Either String [Extension]
-> Ghc (Maybe [Text])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (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]
errorLines)
                ( \[Extension]
es -> do
                    String -> [Extension] -> Ghc ()
forall (m :: * -> *) a1 a2.
(MonadIO m, Show a1, Show a2) =>
a1 -> a2 -> m ()
dbg String
"{:SET" [Extension]
es
                    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
                    (Extension -> Ghc ()) -> [Extension] -> Ghc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Extension -> Ghc ()
forall (m :: * -> *). GhcMonad m => Extension -> m ()
addExtension [Extension]
es
                    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
"post set" (String -> Ghc ()) -> String -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
showDynFlags DynFlags
ndf
                    Maybe [Text] -> Ghc (Maybe [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Text]
forall a. Maybe a
Nothing
                )
                (Either String [Extension] -> Ghc (Maybe [Text]))
-> Either String [Extension] -> Ghc (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ String -> Either String [Extension]
ghcOptions String
stmt
        | -- 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 -> Int -> Ghc ExecResult
forall (m :: * -> *). GhcMonad m => String -> Int -> m ExecResult
exec String
stmt Int
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 -> Int -> m ExecResult
exec String
stmt Int
l =
        let opts :: ExecOptions
opts = ExecOptions
execOptions{execSourceFile :: String
execSourceFile = String
fp, execLineNumber :: Int
execLineNumber = Int
l}
         in String -> ExecOptions -> m ExecResult
forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
execStmt String
stmt ExecOptions
opts

runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnvEq
runGetSession :: IdeState -> NormalizedFilePath -> m HscEnvEq
runGetSession IdeState
st NormalizedFilePath
nfp =
    IO HscEnvEq -> m HscEnvEq
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnvEq -> m HscEnvEq) -> IO HscEnvEq -> m HscEnvEq
forall a b. (a -> b) -> a -> b
$
        String -> IdeState -> Action HscEnvEq -> IO HscEnvEq
forall a. String -> IdeState -> Action a -> IO a
runAction String
"getSession" IdeState
st (Action HscEnvEq -> IO HscEnvEq) -> Action HscEnvEq -> IO HscEnvEq
forall a b. (a -> b) -> a -> b
$
            GhcSession -> NormalizedFilePath -> Action HscEnvEq
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_
                GhcSession
GhcSession
                -- GhcSessionDeps
                NormalizedFilePath
nfp

needsQuickCheck :: [(Section, Loc Test)] -> Bool
needsQuickCheck :: [(Section, Loc Test)] -> Bool
needsQuickCheck = ((Section, Loc Test) -> Bool) -> [(Section, Loc Test)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Test -> Bool
isProperty (Test -> Bool)
-> ((Section, Loc Test) -> Test) -> (Section, Loc Test) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc Test -> Test
forall l a. Located l a -> a
unLoc (Loc Test -> Test)
-> ((Section, Loc Test) -> Loc Test) -> (Section, Loc Test) -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Section, Loc Test) -> Loc 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

{-
Check that extensions actually exists.

>>> ghcOptions ":set -XLambdaCase"
Right [LambdaCase]
>>> ghcOptions ":set -XLambdaCase -XNotRight"
Left "Unknown extension: \"NotRight\""
-}
ghcOptions :: [Char] -> Either String [LangExt.Extension]
ghcOptions :: String -> Either String [Extension]
ghcOptions = (String -> Either String [Extension])
-> ([String] -> Either String [Extension])
-> Either String [String]
-> Either String [Extension]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either String [Extension]
forall a b. a -> Either a b
Left ((String -> Either String Extension)
-> [String] -> Either String [Extension]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Either String Extension
chk) (Either String [String] -> Either String [Extension])
-> (String -> Either String [String])
-> String
-> Either String [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String [String]
langOptions
  where
    chk :: String -> Either String Extension
chk String
o =
        Either String Extension
-> (Extension -> Either String Extension)
-> Maybe Extension
-> Either String Extension
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> Either String Extension
forall a b. a -> Either a b
Left (String -> Either String Extension)
-> String -> Either String Extension
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Unknown extension:", ShowS
forall a. Show a => a -> String
show String
o])
            Extension -> Either String Extension
forall a b. b -> Either a b
Right
            (String -> Maybe Extension
forall a. Read a => String -> Maybe a
readMaybe String
o :: Maybe LangExt.Extension)

{- |
>>> 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
""

{-
Normalise preprocessed source code (from a CPP/LHS or other processed file) so that tests are on the same lines as in the original source.

>>> cleanSource True $ T.pack "#line 1 \nA comment\n> module X where"
"comment\nmodule X where\n"

>>> cleanSource False $ T.pack "#1  \nmodule X where"
"module X where\n"
-}
cleanSource :: Bool -> Text -> Text
cleanSource :: Bool -> Text -> Text
cleanSource Bool
isLit =
    [Text] -> Text
T.unlines
        ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isLit then (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
cleanBirdCode else [Text] -> [Text]
forall a. a -> a
id)
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Text
t -> Text -> Bool
T.null Text
t Bool -> Bool -> Bool
|| (Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#'))
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

cleanBirdCode :: Text -> Text
cleanBirdCode :: Text -> Text
cleanBirdCode = Int -> Text -> Text
T.drop Int
2

{- | 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
$$ Int -> MsgDoc -> MsgDoc
nest Int
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 :: Int -> GhciLikeCmdException -> ShowS
showsPrec Int
_ GhciLikeCmdNotImplemented{Text
ghciCmdArg :: Text
ghciCmdName :: Text
$sel:ghciCmdArg:GhciLikeCmdNotImplemented :: GhciLikeCmdException -> Text
$sel:ghciCmdName:GhciLikeCmdNotImplemented :: GhciLikeCmdException -> Text
..} =
        String -> ShowS
showString String
"unknown command '"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Text -> String
T.unpack Text
ghciCmdName)
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
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