{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Haskell.Debug.Adapter.State.Init.Launch where

import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.State
import Control.Concurrent
import Control.Lens
import Text.Parsec
import qualified Text.Read as R
import qualified System.Log.Logger as L
import qualified Data.ByteString.Lazy as LB
import qualified Data.List as L
import qualified Data.Version as V

import qualified Haskell.DAP as DAP
import qualified Haskell.Debug.Adapter.Utility as U
import qualified Haskell.Debug.Adapter.State.Utility as SU
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant
import qualified Haskell.Debug.Adapter.Logger as L
import qualified Haskell.Debug.Adapter.GHCi as P


-- |
--   Any errors should be critical. don't catch anything here.
--
instance StateActivityIF InitStateData DAP.LaunchRequest where
  action :: AppState InitStateData
-> Request LaunchRequest -> AppContext (Maybe StateTransit)
action AppState InitStateData
_ (LaunchRequest LaunchRequest
req) = do
    IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"InitState LaunchRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ LaunchRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show LaunchRequest
req
    LaunchRequest -> AppContext (Maybe StateTransit)
app LaunchRequest
req

-- |
--   @see https://github.com/Microsoft/vscode/issues/4902
--   @see https://microsoft.github.io/debug-adapter-protocol/overview
--
app :: DAP.LaunchRequest -> AppContext (Maybe StateTransit)
app :: LaunchRequest -> AppContext (Maybe StateTransit)
app LaunchRequest
req = (AppContext (Maybe StateTransit)
 -> (ErrMsg -> AppContext (Maybe StateTransit))
 -> AppContext (Maybe StateTransit))
-> (ErrMsg -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext (Maybe StateTransit)
-> (ErrMsg -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ErrMsg -> AppContext (Maybe StateTransit)
errHdl (AppContext (Maybe StateTransit)
 -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b. (a -> b) -> a -> b
$ do

  LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
setUpConfig LaunchRequest
req
  LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
setUpLogger LaunchRequest
req

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendStdoutEvent ErrMsg
"Configuration read.\n"
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEvent ErrMsg
"Starting GHCi.\n"
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendErrorEvent ErrMsg
"Wait for a moment.\n\n"

  -- must start here. can not start in the entry of GHCiRun State.
  -- because there is a transition from DebugRun to GHCiRun.
  LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
startGHCi LaunchRequest
req
  StateT AppStores (ExceptT ErrMsg IO) ()
setPrompt
  LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
launchCmd LaunchRequest
req
  StateT AppStores (ExceptT ErrMsg IO) ()
setMainArgs
  StateT AppStores (ExceptT ErrMsg IO) ()
loadStarupFile

  -- dont send launch response here.
  -- it must send after configuration done response.
  (AppStores -> AppStores) -> StateT AppStores (ExceptT ErrMsg IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AppStores -> AppStores)
 -> StateT AppStores (ExceptT ErrMsg IO) ())
-> (AppStores -> AppStores)
-> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ \AppStores
s-> AppStores
s{_launchReqSeqAppStores :: Int
_launchReqSeqAppStores = LaunchRequest -> Int
DAP.seqLaunchRequest LaunchRequest
req}

  -- after initialized event, vscode send setBreak... and
  -- ConfigurationDone request.
  Int
initSeq <- AppContext Int
U.getIncreasedResponseSequence
  Response -> StateT AppStores (ExceptT ErrMsg IO) ()
U.addResponse (Response -> StateT AppStores (ExceptT ErrMsg IO) ())
-> Response -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ InitializedEvent -> Response
InitializedEvent (InitializedEvent -> Response) -> InitializedEvent -> Response
forall a b. (a -> b) -> a -> b
$ InitializedEvent
DAP.defaultInitializedEvent {seqInitializedEvent :: Int
DAP.seqInitializedEvent = Int
initSeq}

  Maybe StateTransit -> AppContext (Maybe StateTransit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateTransit -> AppContext (Maybe StateTransit))
-> Maybe StateTransit -> AppContext (Maybe StateTransit)
forall a b. (a -> b) -> a -> b
$ StateTransit -> Maybe StateTransit
forall a. a -> Maybe a
Just StateTransit
Init_GHCiRun

  where
    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
msg = do
      IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.errorM ErrMsg
_LOG_APP ErrMsg
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: LaunchResponse
res = LaunchResponse
DAP.defaultLaunchResponse {
                seqLaunchResponse :: Int
DAP.seqLaunchResponse = Int
resSeq
              , request_seqLaunchResponse :: Int
DAP.request_seqLaunchResponse = LaunchRequest -> Int
DAP.seqLaunchRequest LaunchRequest
req
              , successLaunchResponse :: Bool
DAP.successLaunchResponse = Bool
False
              , messageLaunchResponse :: ErrMsg
DAP.messageLaunchResponse = ErrMsg
msg
              }

      Response -> StateT AppStores (ExceptT ErrMsg IO) ()
U.addResponse (Response -> StateT AppStores (ExceptT ErrMsg IO) ())
-> Response -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ LaunchResponse -> Response
LaunchResponse LaunchResponse
res
      Maybe StateTransit -> AppContext (Maybe StateTransit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing


-- |
--
setUpConfig :: DAP.LaunchRequest -> AppContext ()
setUpConfig :: LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
setUpConfig LaunchRequest
req = do
  let args :: LaunchRequestArguments
args = LaunchRequest -> LaunchRequestArguments
DAP.argumentsLaunchRequest LaunchRequest
req
  AppStores
appStores <- StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get

  let wsMVar :: MVar ErrMsg
wsMVar = AppStores
appStoresAppStores
-> Getting (MVar ErrMsg) AppStores (MVar ErrMsg) -> MVar ErrMsg
forall s a. s -> Getting a s a -> a
^.Getting (MVar ErrMsg) AppStores (MVar ErrMsg)
Lens' AppStores (MVar ErrMsg)
workspaceAppStores
      ws :: ErrMsg
ws = LaunchRequestArguments -> ErrMsg
DAP.workspaceLaunchRequestArguments LaunchRequestArguments
args
  ErrMsg
_ <- IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b. (a -> b) -> a -> b
$ MVar ErrMsg -> IO ErrMsg
forall a. MVar a -> IO a
takeMVar MVar ErrMsg
wsMVar
  IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ MVar ErrMsg -> ErrMsg -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ErrMsg
wsMVar ErrMsg
ws
  IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"workspace is " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
ws

  let logPRMVar :: MVar Priority
logPRMVar = AppStores
appStoresAppStores
-> Getting (MVar Priority) AppStores (MVar Priority)
-> MVar Priority
forall s a. s -> Getting a s a -> a
^.Getting (MVar Priority) AppStores (MVar Priority)
Lens' AppStores (MVar Priority)
logPriorityAppStores
  Priority
logPR <- ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) Priority
getLogPriority (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) Priority)
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall a b. (a -> b) -> a -> b
$ LaunchRequestArguments -> ErrMsg
DAP.logLevelLaunchRequestArguments LaunchRequestArguments
args
  Priority
_ <- IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority)
-> IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall a b. (a -> b) -> a -> b
$ MVar Priority -> IO Priority
forall a. MVar a -> IO a
takeMVar MVar Priority
logPRMVar
  IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ MVar Priority -> Priority -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Priority
logPRMVar Priority
logPR

  AppStores -> StateT AppStores (ExceptT ErrMsg IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppStores
appStores {
      _startupAppStores :: ErrMsg
_startupAppStores     = ErrMsg -> ErrMsg -> ErrMsg -> ErrMsg
U.replace [Char
_SEP_WIN] [Char
_SEP_UNIX] (LaunchRequestArguments -> ErrMsg
DAP.startupLaunchRequestArguments LaunchRequestArguments
args)
    , _startupFuncAppStores :: ErrMsg
_startupFuncAppStores = ErrMsg -> (ErrMsg -> ErrMsg) -> Maybe ErrMsg -> ErrMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ErrMsg
"" (\ErrMsg
s->if ErrMsg -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ErrMsg -> ErrMsg
U.strip ErrMsg
s) then ErrMsg
"" else  (ErrMsg -> ErrMsg
U.strip ErrMsg
s)) (LaunchRequestArguments -> Maybe ErrMsg
DAP.startupFuncLaunchRequestArguments LaunchRequestArguments
args)
    , _startupArgsAppStores :: ErrMsg
_startupArgsAppStores = ErrMsg -> (ErrMsg -> ErrMsg) -> Maybe ErrMsg -> ErrMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ErrMsg
"" (ErrMsg -> ErrMsg
forall a. a -> a
id) (LaunchRequestArguments -> Maybe ErrMsg
DAP.startupArgsLaunchRequestArguments LaunchRequestArguments
args)
    , _stopOnEntryAppStores :: Bool
_stopOnEntryAppStores = LaunchRequestArguments -> Bool
DAP.stopOnEntryLaunchRequestArguments LaunchRequestArguments
args
    , _mainArgsAppStores :: ErrMsg
_mainArgsAppStores    = ErrMsg -> (ErrMsg -> ErrMsg) -> Maybe ErrMsg -> ErrMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ErrMsg
"" (ErrMsg -> ErrMsg
forall a. a -> a
id) (LaunchRequestArguments -> Maybe ErrMsg
DAP.mainArgsLaunchRequestArguments LaunchRequestArguments
args)
    }

  where
    getLogPriority :: ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) Priority
getLogPriority ErrMsg
logPRStr = case ErrMsg -> Either ErrMsg Priority
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
logPRStr of
      Right Priority
lv -> Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
lv
      Left ErrMsg
err -> do
        ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendErrorEvent (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"log priority is invalid. WARNING set. [" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"]\n"
        Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
L.WARNING

-- |
--
setUpLogger :: DAP.LaunchRequest -> AppContext ()
setUpLogger :: LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
setUpLogger LaunchRequest
req = do
  let args :: LaunchRequestArguments
args = LaunchRequest -> LaunchRequestArguments
DAP.argumentsLaunchRequest LaunchRequest
req
  AppStores
ctx <- StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  Priority
logPR <- IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority)
-> IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall a b. (a -> b) -> a -> b
$ MVar Priority -> IO Priority
forall a. MVar a -> IO a
readMVar (MVar Priority -> IO Priority) -> MVar Priority -> IO Priority
forall a b. (a -> b) -> a -> b
$ AppStores
ctxAppStores
-> Getting (MVar Priority) AppStores (MVar Priority)
-> MVar Priority
forall s a. s -> Getting a s a -> a
^.Getting (MVar Priority) AppStores (MVar Priority)
Lens' AppStores (MVar Priority)
logPriorityAppStores

  IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> Priority -> IO ()
L.setUpLogger (LaunchRequestArguments -> ErrMsg
DAP.logFileLaunchRequestArguments LaunchRequestArguments
args) Priority
logPR


-- |
--
startGHCi :: DAP.LaunchRequest -> AppContext ()
startGHCi :: LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
startGHCi LaunchRequest
req = do
  let args :: LaunchRequestArguments
args = LaunchRequest -> LaunchRequestArguments
DAP.argumentsLaunchRequest LaunchRequest
req
      initPmpt :: ErrMsg
initPmpt = ErrMsg -> (ErrMsg -> ErrMsg) -> Maybe ErrMsg -> ErrMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ErrMsg
_GHCI_PROMPT ErrMsg -> ErrMsg
forall a. a -> a
id (LaunchRequestArguments -> Maybe ErrMsg
DAP.ghciInitialPromptLaunchRequestArguments LaunchRequestArguments
args)
      envs :: Map ErrMsg ErrMsg
envs = LaunchRequestArguments -> Map ErrMsg ErrMsg
DAP.ghciEnvLaunchRequestArguments LaunchRequestArguments
args
      cmdStr :: ErrMsg
cmdStr = LaunchRequestArguments -> ErrMsg
DAP.ghciCmdLaunchRequestArguments LaunchRequestArguments
args
      cmdList :: [ErrMsg]
cmdList = (ErrMsg -> Bool) -> [ErrMsg] -> [ErrMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (ErrMsg -> Bool) -> ErrMsg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ErrMsg -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> [ErrMsg]
U.split ErrMsg
" " ErrMsg
cmdStr
      cmd :: ErrMsg
cmd  = [ErrMsg] -> ErrMsg
forall a. [a] -> a
head [ErrMsg]
cmdList

  ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.debugEV ErrMsg
_LOG_APP (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> ErrMsg
forall a. Show a => a -> ErrMsg
show [ErrMsg]
cmdList

  [ErrMsg]
opts <- [ErrMsg] -> AppContext [ErrMsg]
addWithGHC ([ErrMsg] -> [ErrMsg]
forall a. [a] -> [a]
tail [ErrMsg]
cmdList)

  AppStores
appStores <- StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  ErrMsg
cwd <- IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a. IO a -> AppContext a
U.liftIOE (IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> IO ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b. (a -> b) -> a -> b
$ MVar ErrMsg -> IO ErrMsg
forall a. MVar a -> IO a
readMVar (MVar ErrMsg -> IO ErrMsg) -> MVar ErrMsg -> IO ErrMsg
forall a b. (a -> b) -> a -> b
$ AppStores
appStoresAppStores
-> Getting (MVar ErrMsg) AppStores (MVar ErrMsg) -> MVar ErrMsg
forall s a. s -> Getting a s a -> a
^.Getting (MVar ErrMsg) AppStores (MVar ErrMsg)
Lens' AppStores (MVar ErrMsg)
workspaceAppStores

  IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. IO a -> AppContext a
U.liftIOE (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"ghci initial prompt [" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
initPmpt ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"]."

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEventLF (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"CWD: " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
cwd
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEventLF (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"CMD: " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg -> [ErrMsg] -> ErrMsg
forall a. [a] -> [[a]] -> [a]
L.intercalate ErrMsg
" " (ErrMsg
cmd ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
: [ErrMsg]
opts)
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEventLF ErrMsg
""

  ErrMsg
-> [ErrMsg]
-> ErrMsg
-> Map ErrMsg ErrMsg
-> StateT AppStores (ExceptT ErrMsg IO) ()
P.startGHCi ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendErrorEventLF (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"Now, waiting for an initial prompt(\""ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
initPmptErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
"\")" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" from ghci."
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEventLF ErrMsg
""
  [ErrMsg]
res <- ErrMsg -> AppContext [ErrMsg]
P.expectInitPmpt ErrMsg
initPmpt

  [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ()
updateGHCiVersion [ErrMsg]
res

  where

    updateGHCiVersion :: [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ()
updateGHCiVersion [ErrMsg]
acc = case Parsec ErrMsg () Version
-> ErrMsg -> ErrMsg -> Either ParseError Version
forall s t a.
Stream s Identity t =>
Parsec s () a -> ErrMsg -> s -> Either ParseError a
parse Parsec ErrMsg () Version
forall u. ParsecT ErrMsg u Identity Version
verParser ErrMsg
"getGHCiVersion" ([ErrMsg] -> ErrMsg
unlines [ErrMsg]
acc) of
      Right Version
v -> do
        ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.debugEV ErrMsg
_LOG_APP (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"GHCi version is " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ Version -> ErrMsg
V.showVersion Version
v
        Version -> StateT AppStores (ExceptT ErrMsg IO) ()
updateGHCiVersion' Version
v
      Left ParseError
e  -> do
        ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.sendConsoleEventLF (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"Can not parse ghci version. [" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ParseError -> ErrMsg
forall a. Show a => a -> ErrMsg
show ParseError
e ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"]. Assumes "  ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ Version -> ErrMsg
V.showVersion Version
_BASE_GHCI_VERSION ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"."
        Version -> StateT AppStores (ExceptT ErrMsg IO) ()
updateGHCiVersion' Version
_BASE_GHCI_VERSION

    verParser :: ParsecT ErrMsg u Identity Version
verParser = do
      ErrMsg
_ <- ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity ErrMsg
-> ParsecT ErrMsg u Identity ErrMsg
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT ErrMsg u Identity ErrMsg
-> ParsecT ErrMsg u Identity ErrMsg
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ErrMsg -> ParsecT ErrMsg u Identity ErrMsg
forall s (m :: * -> *) u.
Stream s m Char =>
ErrMsg -> ParsecT s u m ErrMsg
string ErrMsg
"GHCi, version "))
      ErrMsg
v1 <- ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity ErrMsg
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
      ErrMsg
v2 <- ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity ErrMsg
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
      ErrMsg
v3 <- ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity Char
-> ParsecT ErrMsg u Identity ErrMsg
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT ErrMsg u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')
      Version -> ParsecT ErrMsg u Identity Version
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> ParsecT ErrMsg u Identity Version)
-> Version -> ParsecT ErrMsg u Identity Version
forall a b. (a -> b) -> a -> b
$ [Int] -> Version
V.makeVersion [ErrMsg -> Int
forall a. Read a => ErrMsg -> a
read ErrMsg
v1, ErrMsg -> Int
forall a. Read a => ErrMsg -> a
read ErrMsg
v2, ErrMsg -> Int
forall a. Read a => ErrMsg -> a
read ErrMsg
v3]

    updateGHCiVersion' :: Version -> StateT AppStores (ExceptT ErrMsg IO) ()
updateGHCiVersion' Version
v = do
      MVar Version
mver <- Getting (MVar Version) AppStores (MVar Version)
-> AppStores -> MVar Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar Version) AppStores (MVar Version)
Lens' AppStores (MVar Version)
ghciVerAppStores (AppStores -> MVar Version)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
      IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. IO a -> AppContext a
U.liftIOE (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ MVar Version -> Version -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Version
mver Version
v

-- |
--
setPrompt :: AppContext ()
setPrompt :: StateT AppStores (ExceptT ErrMsg IO) ()
setPrompt = do
  ErrMsg
p <- Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
ghciPmptAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  let pmpt :: ErrMsg
pmpt = ErrMsg
_DAP_CMD_END2 ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"\\n" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
p
      cmd :: ErrMsg
cmd  = ErrMsg
":set prompt \""ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
pmptErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
"\""
      cmd2 :: ErrMsg
cmd2 = ErrMsg
":set prompt-cont \""ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
pmptErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
"\""

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd
  AppContext [ErrMsg]
P.expectPmpt

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd2
  AppContext [ErrMsg]
P.expectPmpt

  () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |
--
launchCmd :: DAP.LaunchRequest -> AppContext ()
launchCmd :: LaunchRequest -> StateT AppStores (ExceptT ErrMsg IO) ()
launchCmd LaunchRequest
req = do
  let args :: LaunchRequestArguments
args = LaunchRequest -> LaunchRequestArguments
DAP.argumentsLaunchRequest LaunchRequest
req
      dap :: ErrMsg
dap = ErrMsg
":dap-launch "
      cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ LaunchRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP LaunchRequestArguments
args
      dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ LaunchRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
show LaunchRequestArguments
args

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd
  ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.debugEV ErrMsg
_LOG_APP ErrMsg
dbg
  AppContext [ErrMsg]
P.expectPmpt

  () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |
--
setMainArgs :: AppContext ()
setMainArgs :: StateT AppStores (ExceptT ErrMsg IO) ()
setMainArgs = Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
mainArgsAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get StateT AppStores (ExceptT ErrMsg IO) ErrMsg
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] -> () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ErrMsg
args -> do
    let cmd :: ErrMsg
cmd  = ErrMsg
":set args "ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ErrMsg
args

    ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd
    AppContext [ErrMsg]
P.expectPmpt

    () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |
--
loadStarupFile :: AppContext ()
loadStarupFile :: StateT AppStores (ExceptT ErrMsg IO) ()
loadStarupFile = do
  ErrMsg
file <- Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
startupAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
SU.loadHsFile ErrMsg
file

  let cmd :: ErrMsg
cmd  = ErrMsg
":dap-context-modules "

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd
  AppContext [ErrMsg]
P.expectPmpt

  () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |
--
addWithGHC :: [String] -> AppContext [String]
addWithGHC :: [ErrMsg] -> AppContext [ErrMsg]
addWithGHC [] = [ErrMsg] -> AppContext [ErrMsg]
forall (m :: * -> *) a. Monad m => a -> m a
return []
addWithGHC [ErrMsg]
cmds
  | ErrMsg -> [ErrMsg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.elem ErrMsg
"--with-ghc=haskell-dap" [ErrMsg]
cmds = do
    ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.infoEV ErrMsg
_LOG_APP ErrMsg
"can not use haskell-dap. deleting \"--with-ghc=haskell-dap\""
    [ErrMsg] -> AppContext [ErrMsg]
addWithGHC ([ErrMsg] -> AppContext [ErrMsg])
-> [ErrMsg] -> AppContext [ErrMsg]
forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. Eq a => a -> [a] -> [a]
L.delete ErrMsg
"--with-ghc=haskell-dap" [ErrMsg]
cmds
  | [ErrMsg] -> Bool
withGhciExists [ErrMsg]
cmds = [ErrMsg] -> AppContext [ErrMsg]
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
cmds
  | ErrMsg
"ghci" ErrMsg -> ErrMsg -> Bool
forall a. Eq a => a -> a -> Bool
== [ErrMsg] -> ErrMsg
forall a. [a] -> a
head [ErrMsg]
cmds = do
    ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.infoEV ErrMsg
_LOG_APP ErrMsg
"\"--with-ghc\" option not found. adding \"--with-ghc=ghci-dap\""
    [ErrMsg] -> AppContext [ErrMsg]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrMsg] -> AppContext [ErrMsg])
-> [ErrMsg] -> AppContext [ErrMsg]
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> ErrMsg
forall a. [a] -> a
head [ErrMsg]
cmdsErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:ErrMsg
"--with-ghc=ghci-dap"ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:[ErrMsg] -> [ErrMsg]
forall a. [a] -> [a]
tail [ErrMsg]
cmds
  | Bool
otherwise = [ErrMsg] -> AppContext [ErrMsg]
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
cmds
  where
    withGhciExists :: [ErrMsg] -> Bool
withGhciExists [] = Bool
False
    withGhciExists (ErrMsg
x:[ErrMsg]
xs)
      | ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf ErrMsg
"--with-ghc=" ErrMsg
x = Bool
True
      | Bool
otherwise = [ErrMsg] -> Bool
withGhciExists [ErrMsg]
xs


-- |
--
_TASKS_JSON_FILE_CONTENTS :: LB.ByteString
_TASKS_JSON_FILE_CONTENTS :: ByteString
_TASKS_JSON_FILE_CONTENTS = ErrMsg -> ByteString
U.str2lbs (ErrMsg -> ByteString) -> ErrMsg -> ByteString
forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg] -> ErrMsg
U.join ErrMsg
"\n" ([ErrMsg] -> ErrMsg) -> [ErrMsg] -> ErrMsg
forall a b. (a -> b) -> a -> b
$
  [
    ErrMsg
"{"
  , ErrMsg
"  // atuomatically created by phoityne-vscode"
  , ErrMsg
"  "
  , ErrMsg
"  \"version\": \"2.0.0\","
  , ErrMsg
"  \"presentation\": {"
  , ErrMsg
"    \"reveal\": \"always\","
  , ErrMsg
"    \"panel\": \"new\""
  , ErrMsg
"  },"
  , ErrMsg
"  \"tasks\": ["
  , ErrMsg
"    {"
  , ErrMsg
"      \"group\": {"
  , ErrMsg
"        \"kind\": \"build\","
  , ErrMsg
"        \"isDefault\": true"
  , ErrMsg
"      },"
  , ErrMsg
"      \"label\": \"stack build\","
  , ErrMsg
"      \"type\": \"shell\","
  , ErrMsg
"      \"command\": \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \""
  , ErrMsg
"    },"
  , ErrMsg
"    { "
  , ErrMsg
"      \"group\": \"build\","
  , ErrMsg
"      \"type\": \"shell\","
  , ErrMsg
"      \"label\": \"stack clean & build\","
  , ErrMsg
"      \"command\": \"echo START_STACK_CLEAN_AND_BUILD && cd ${workspaceRoot} && stack clean && stack build && echo END_STACK_CLEAN_AND_BUILD \""
  , ErrMsg
"    },"
  , ErrMsg
"    { "
  , ErrMsg
"      \"group\": {"
  , ErrMsg
"        \"kind\": \"test\","
  , ErrMsg
"        \"isDefault\": true"
  , ErrMsg
"      },"
  , ErrMsg
"      \"type\": \"shell\","
  , ErrMsg
"      \"label\": \"stack test\","
  , ErrMsg
"      \"command\": \"echo START_STACK_TEST && cd ${workspaceRoot} && stack test && echo END_STACK_TEST \""
  , ErrMsg
"    },"
  , ErrMsg
"    { "
  , ErrMsg
"      \"isBackground\": true,"
  , ErrMsg
"      \"type\": \"shell\","
  , ErrMsg
"      \"label\": \"stack watch\","
  , ErrMsg
"      \"command\": \"echo START_STACK_WATCH && cd ${workspaceRoot} && stack build --test --no-run-tests --file-watch && echo END_STACK_WATCH \""
  , ErrMsg
"    }"
  , ErrMsg
"  ]"
  , ErrMsg
"}"
  ]