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

module Haskell.Debug.Adapter.State.Utility where

import qualified System.Log.Logger as L
import qualified Text.Read as R
import Control.Monad.Except
import Control.Lens
import Control.Monad.State.Lazy
import Control.Concurrent.MVar

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant
import qualified Haskell.Debug.Adapter.Utility as U
import qualified Haskell.Debug.Adapter.GHCi as P


-- |
--
setBreakpointsRequest :: DAP.SetBreakpointsRequest -> AppContext (Maybe StateTransit)
setBreakpointsRequest :: SetBreakpointsRequest -> AppContext (Maybe StateTransit)
setBreakpointsRequest SetBreakpointsRequest
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 a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
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
  let args :: SetBreakpointsRequestArguments
args = SetBreakpointsRequest -> SetBreakpointsRequestArguments
DAP.argumentsSetBreakpointsRequest SetBreakpointsRequest
req
      dap :: ErrMsg
dap = ErrMsg
":dap-set-breakpoints "
      cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetBreakpointsRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP SetBreakpointsRequestArguments
args
      dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetBreakpointsRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
show SetBreakpointsRequestArguments
args

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  ErrMsg -> ErrMsg -> AppContext ()
U.debugEV ErrMsg
_LOG_APP ErrMsg
dbg
  AppContext [ErrMsg]
P.expectPmpt AppContext [ErrMsg]
-> ([ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
takeDapResult StateT AppStores (ExceptT ErrMsg IO) ErrMsg
-> (ErrMsg -> AppContext ()) -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg -> AppContext ()
dapHdl

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

  where
    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: ErrMsg -> AppContext ()
dapHdl ErrMsg
str = case ErrMsg -> Either ErrMsg (Either ErrMsg SetBreakpointsResponseBody)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
str of
      Left ErrMsg
err -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Left ErrMsg
err) -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Right SetBreakpointsResponseBody
body) -> do
        Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
        let res :: SetBreakpointsResponse
res = SetBreakpointsResponse
DAP.defaultSetBreakpointsResponse {
                  DAP.seqSetBreakpointsResponse = resSeq
                , DAP.request_seqSetBreakpointsResponse = DAP.seqSetBreakpointsRequest req
                , DAP.successSetBreakpointsResponse = True
                , DAP.bodySetBreakpointsResponse = body
                }

        Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ SetBreakpointsResponse -> Response
SetBreakpointsResponse SetBreakpointsResponse
res

    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
msg = do
      ErrMsg -> ErrMsg -> AppContext ()
U.errorEV ErrMsg
_LOG_APP ErrMsg
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: SetBreakpointsResponse
res = SetBreakpointsResponse
DAP.defaultSetBreakpointsResponse {
                DAP.seqSetBreakpointsResponse = resSeq
              , DAP.request_seqSetBreakpointsResponse = DAP.seqSetBreakpointsRequest req
              , DAP.successSetBreakpointsResponse = False
              , DAP.messageSetBreakpointsResponse = msg
              }

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


-- |
--
setExceptionBreakpointsRequest :: DAP.SetExceptionBreakpointsRequest -> AppContext (Maybe StateTransit)
setExceptionBreakpointsRequest :: SetExceptionBreakpointsRequest -> AppContext (Maybe StateTransit)
setExceptionBreakpointsRequest SetExceptionBreakpointsRequest
req = do
  let args :: SetExceptionBreakpointsRequestArguments
args = SetExceptionBreakpointsRequest
-> SetExceptionBreakpointsRequestArguments
DAP.argumentsSetExceptionBreakpointsRequest SetExceptionBreakpointsRequest
req
      filters :: [ErrMsg]
filters = SetExceptionBreakpointsRequestArguments -> [ErrMsg]
DAP.filtersSetExceptionBreakpointsRequestArguments SetExceptionBreakpointsRequestArguments
args

  (ErrMsg -> AppContext [ErrMsg]) -> [ErrMsg] -> AppContext ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ErrMsg -> AppContext [ErrMsg]
go ([ErrMsg] -> AppContext ()) -> [ErrMsg] -> AppContext ()
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> [ErrMsg]
getOptions [ErrMsg]
filters

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
  let res :: SetExceptionBreakpointsResponse
res = SetExceptionBreakpointsResponse
DAP.defaultSetExceptionBreakpointsResponse {
            DAP.seqSetExceptionBreakpointsResponse = resSeq
          , DAP.request_seqSetExceptionBreakpointsResponse = DAP.seqSetExceptionBreakpointsRequest req
          , DAP.successSetExceptionBreakpointsResponse = True
          }

  Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ SetExceptionBreakpointsResponse -> Response
SetExceptionBreakpointsResponse SetExceptionBreakpointsResponse
res

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

  where
    getOptions :: [ErrMsg] -> [ErrMsg]
getOptions [ErrMsg]
filters
      | [ErrMsg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
filters                      = [ErrMsg
"-fno-break-on-exception", ErrMsg
"-fno-break-on-error"]
      | [ErrMsg]
filters [ErrMsg] -> [ErrMsg] -> Bool
forall a. Eq a => a -> a -> Bool
== [ErrMsg
"break-on-error"]     = [ErrMsg
"-fno-break-on-exception", ErrMsg
"-fbreak-on-error"]
      | [ErrMsg]
filters [ErrMsg] -> [ErrMsg] -> Bool
forall a. Eq a => a -> a -> Bool
== [ErrMsg
"break-on-exception"] = [ErrMsg
"-fbreak-on-exception",    ErrMsg
"-fno-break-on-error"]
      | Bool
otherwise                         = [ErrMsg
"-fbreak-on-exception",    ErrMsg
"-fbreak-on-error" ]

    go :: ErrMsg -> AppContext [ErrMsg]
go ErrMsg
opt = do
      let cmd :: ErrMsg
cmd = ErrMsg
":set " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
opt

      ErrMsg -> AppContext ()
P.command ErrMsg
cmd
      AppContext [ErrMsg]
P.expectPmpt



-- |
--
setFunctionBreakpointsRequest :: DAP.SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)
setFunctionBreakpointsRequest :: SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)
setFunctionBreakpointsRequest SetFunctionBreakpointsRequest
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 a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
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
  let args :: SetFunctionBreakpointsRequestArguments
args = SetFunctionBreakpointsRequest
-> SetFunctionBreakpointsRequestArguments
DAP.argumentsSetFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req
      dap :: ErrMsg
dap = ErrMsg
":dap-set-function-breakpoints "
      cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetFunctionBreakpointsRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP SetFunctionBreakpointsRequestArguments
args
      dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetFunctionBreakpointsRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
show SetFunctionBreakpointsRequestArguments
args

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  ErrMsg -> ErrMsg -> AppContext ()
U.debugEV ErrMsg
_LOG_APP ErrMsg
dbg
  AppContext [ErrMsg]
P.expectPmpt AppContext [ErrMsg]
-> ([ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
takeDapResult StateT AppStores (ExceptT ErrMsg IO) ErrMsg
-> (ErrMsg -> AppContext ()) -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg -> AppContext ()
dapHdl

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

  where

    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: ErrMsg -> AppContext ()
dapHdl ErrMsg
str = case ErrMsg
-> Either ErrMsg (Either ErrMsg SetFunctionBreakpointsResponseBody)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
str of
      Left ErrMsg
err -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Left ErrMsg
err) -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Right SetFunctionBreakpointsResponseBody
body) -> do
        Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
        let res :: SetFunctionBreakpointsResponse
res = SetFunctionBreakpointsResponse
DAP.defaultSetFunctionBreakpointsResponse {
                  DAP.seqSetFunctionBreakpointsResponse = resSeq
                , DAP.request_seqSetFunctionBreakpointsResponse = DAP.seqSetFunctionBreakpointsRequest req
                , DAP.successSetFunctionBreakpointsResponse = True
                , DAP.bodySetFunctionBreakpointsResponse = body
                }

        Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ SetFunctionBreakpointsResponse -> Response
SetFunctionBreakpointsResponse SetFunctionBreakpointsResponse
res

    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
msg = do
      ErrMsg -> ErrMsg -> AppContext ()
U.errorEV ErrMsg
_LOG_APP ErrMsg
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: SetFunctionBreakpointsResponse
res = SetFunctionBreakpointsResponse
DAP.defaultSetFunctionBreakpointsResponse {
                DAP.seqSetFunctionBreakpointsResponse = resSeq
              , DAP.request_seqSetFunctionBreakpointsResponse = DAP.seqSetFunctionBreakpointsRequest req
              , DAP.successSetFunctionBreakpointsResponse = False
              , DAP.messageSetFunctionBreakpointsResponse = msg
              }

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



-- |
--
terminateGHCi :: AppContext ()
terminateGHCi :: AppContext ()
terminateGHCi = do
  let cmd :: ErrMsg
cmd = ErrMsg
":quit"

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  AppContext [ErrMsg]
P.expectPmpt
  () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |
--
sendDisconnectResponse :: DAP.DisconnectRequest -> AppContext ()
sendDisconnectResponse :: DisconnectRequest -> AppContext ()
sendDisconnectResponse DisconnectRequest
req = do

  AppContext ()
tryTerminateGHCi

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence

  let res :: DisconnectResponse
res = DisconnectResponse
DAP.defaultDisconnectResponse {
            DAP.seqDisconnectResponse         = resSeq
          , DAP.request_seqDisconnectResponse = DAP.seqDisconnectRequest req
          , DAP.successDisconnectResponse     = True
          }

  Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ DisconnectResponse -> Response
DisconnectResponse DisconnectResponse
res

  where
    tryTerminateGHCi :: AppContext ()
    tryTerminateGHCi :: AppContext ()
tryTerminateGHCi = do
      MVar GHCiProc
mver <- Getting (MVar GHCiProc) AppStores (MVar GHCiProc)
-> AppStores -> MVar GHCiProc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar GHCiProc) AppStores (MVar GHCiProc)
Lens' AppStores (MVar GHCiProc)
ghciProcAppStores (AppStores -> MVar GHCiProc)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar GHCiProc)
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 Bool -> AppContext Bool
forall a. IO a -> AppContext a
U.liftIOE (MVar GHCiProc -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar GHCiProc
mver) AppContext Bool -> (Bool -> AppContext ()) -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> AppContext () -> (ErrMsg -> AppContext ()) -> AppContext ()
forall a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError AppContext ()
terminateGHCi (\ErrMsg
_->() -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())


-- |
--
evaluateRequest :: DAP.EvaluateRequest -> AppContext (Maybe StateTransit)
evaluateRequest :: EvaluateRequest -> AppContext (Maybe StateTransit)
evaluateRequest EvaluateRequest
req = do

  let args :: EvaluateRequestArguments
args = EvaluateRequest -> EvaluateRequestArguments
DAP.argumentsEvaluateRequest EvaluateRequest
req
      dap :: ErrMsg
dap = ErrMsg
":dap-evaluate "
      cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ EvaluateRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP EvaluateRequestArguments
args
      dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ EvaluateRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
show EvaluateRequestArguments
args

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  ErrMsg -> ErrMsg -> AppContext ()
U.debugEV ErrMsg
_LOG_APP ErrMsg
dbg
  AppContext [ErrMsg]
P.expectPmpt AppContext [ErrMsg]
-> ([ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
takeDapResult StateT AppStores (ExceptT ErrMsg IO) ErrMsg
-> (ErrMsg -> AppContext ()) -> AppContext ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg -> AppContext ()
dapHdl

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

  where

    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: ErrMsg -> AppContext ()
dapHdl ErrMsg
str = case ErrMsg -> Either ErrMsg (Either ErrMsg EvaluateResponseBody)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
str of
      Left ErrMsg
err -> ErrMsg -> AppContext ()
errHdl (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
      Right (Left ErrMsg
err) -> ErrMsg -> AppContext ()
errHdl ErrMsg
err
      Right (Right EvaluateResponseBody
body) -> do
        Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
        let res :: EvaluateResponse
res = EvaluateResponse
DAP.defaultEvaluateResponse {
                  DAP.seqEvaluateResponse = resSeq
                , DAP.request_seqEvaluateResponse = DAP.seqEvaluateRequest req
                , DAP.successEvaluateResponse = True
                , DAP.bodyEvaluateResponse = body
                }

        Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ EvaluateResponse -> Response
EvaluateResponse EvaluateResponse
res


    -- |
    --
    errHdl :: String -> AppContext ()
    errHdl :: ErrMsg -> AppContext ()
errHdl ErrMsg
msg = do
      ErrMsg -> AppContext ()
U.sendErrorEventLF ErrMsg
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: EvaluateResponse
res = EvaluateResponse
DAP.defaultEvaluateResponse {
                DAP.seqEvaluateResponse = resSeq
              , DAP.request_seqEvaluateResponse = DAP.seqEvaluateRequest req
              , DAP.successEvaluateResponse = False
              , DAP.messageEvaluateResponse = msg
              }

      Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ EvaluateResponse -> Response
EvaluateResponse EvaluateResponse
res

-- |
--
completionsRequest :: DAP.CompletionsRequest -> AppContext (Maybe StateTransit)
completionsRequest :: CompletionsRequest -> AppContext (Maybe StateTransit)
completionsRequest CompletionsRequest
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 a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
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

  let args :: CompletionsRequestArguments
args = CompletionsRequest -> CompletionsRequestArguments
DAP.argumentsCompletionsRequest CompletionsRequest
req
      key :: ErrMsg
key  = CompletionsRequestArguments -> ErrMsg
DAP.textCompletionsRequestArguments CompletionsRequestArguments
args
      size :: ErrMsg
size = ErrMsg
"0-50"
      cmd :: ErrMsg
cmd = ErrMsg
":complete repl " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
size ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" \"" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
key ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"\""

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  [ErrMsg]
outs <- AppContext [ErrMsg]
P.expectPmpt

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
  let items :: [CompletionsItem]
items = [ErrMsg] -> [CompletionsItem]
createItems [ErrMsg]
outs
      body :: CompletionsResponseBody
body  = CompletionsResponseBody
DAP.defaultCompletionsResponseBody {
              DAP.targetsCompletionsResponseBody = items
            }
      res :: CompletionsResponse
res = CompletionsResponse
DAP.defaultCompletionsResponse {
            DAP.seqCompletionsResponse = resSeq
          , DAP.request_seqCompletionsResponse = DAP.seqCompletionsRequest req
          , DAP.successCompletionsResponse = True
          , DAP.bodyCompletionsResponse = body
          }

  Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ CompletionsResponse -> Response
CompletionsResponse CompletionsResponse
res

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

  where
    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
msg = do
      IO () -> AppContext ()
forall a. IO a -> AppContext a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 :: CompletionsResponse
res = CompletionsResponse
DAP.defaultCompletionsResponse {
                DAP.seqCompletionsResponse = resSeq
              , DAP.request_seqCompletionsResponse = DAP.seqCompletionsRequest req
              , DAP.successCompletionsResponse = False
              , DAP.messageCompletionsResponse = msg
              }

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

    -- |
    --
    createItems :: [String] -> [DAP.CompletionsItem]
    createItems :: [ErrMsg] -> [CompletionsItem]
createItems = (ErrMsg -> CompletionsItem) -> [ErrMsg] -> [CompletionsItem]
forall a b. (a -> b) -> [a] -> [b]
map (ErrMsg -> CompletionsItem
createItem (ErrMsg -> CompletionsItem)
-> (ErrMsg -> ErrMsg) -> ErrMsg -> CompletionsItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> ErrMsg
normalize) ([ErrMsg] -> [CompletionsItem])
-> ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [CompletionsItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> [ErrMsg]
extracCompleteList

    -- |
    --
    createItem :: String -> DAP.CompletionsItem
    createItem :: ErrMsg -> CompletionsItem
createItem (Char
':':ErrMsg
xs) = ErrMsg -> CompletionsItem
DAP.CompletionsItem ErrMsg
xs
    createItem ErrMsg
xs = ErrMsg -> CompletionsItem
DAP.CompletionsItem ErrMsg
xs

    -- |
    --
    normalize :: String -> String
    normalize :: ErrMsg -> ErrMsg
normalize ErrMsg
xs
      | Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ErrMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
xs = ErrMsg -> ErrMsg
forall a. HasCallStack => [a] -> [a]
tail (ErrMsg -> ErrMsg) -> (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> ErrMsg
forall a. HasCallStack => [a] -> [a]
init (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$ ErrMsg
xs
      | Bool
otherwise = ErrMsg
xs

    -- |
    --
    extracCompleteList :: [String] -> [String]
    extracCompleteList :: [ErrMsg] -> [ErrMsg]
extracCompleteList [] = []
    extracCompleteList (ErrMsg
_:[]) = []
    extracCompleteList (ErrMsg
_:ErrMsg
_:[]) = []
    extracCompleteList [ErrMsg]
xs = [ErrMsg] -> [ErrMsg]
forall a. HasCallStack => [a] -> [a]
tail ([ErrMsg] -> [ErrMsg])
-> ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> [ErrMsg]
forall a. HasCallStack => [a] -> [a]
init ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ [ErrMsg]
xs



-- |
--
loadHsFile :: FilePath -> AppContext ()
loadHsFile :: ErrMsg -> AppContext ()
loadHsFile ErrMsg
file = do
  let cmd :: ErrMsg
cmd  = ErrMsg
":load "ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
file

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  AppContext [ErrMsg]
P.expectPmpt

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


-- |
--
terminateRequest :: DAP.TerminateRequest -> AppContext ()
terminateRequest :: TerminateRequest -> AppContext ()
terminateRequest TerminateRequest
req = do
  AppContext ()
terminateGHCi

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence

  let res :: TerminateResponse
res = TerminateResponse
DAP.defaultTerminateResponse {
            DAP.seqTerminateResponse         = resSeq
          , DAP.request_seqTerminateResponse = DAP.seqTerminateRequest req
          , DAP.successTerminateResponse     = True
          }

  Response -> AppContext ()
U.addResponse (Response -> AppContext ()) -> Response -> AppContext ()
forall a b. (a -> b) -> a -> b
$ TerminateResponse -> Response
TerminateResponse TerminateResponse
res
  AppContext ()
U.sendTerminatedEvent
  AppContext ()
U.sendExitedEvent

-- |
--
internalTerminateRequest :: AppContext ()
internalTerminateRequest :: AppContext ()
internalTerminateRequest = do

    AppContext ()
terminateGHCi

    AppContext ()
U.sendTerminatedEvent
    AppContext ()
U.sendExitedEvent


-- |
--
takeDapResult :: [String] -> AppContext String
takeDapResult :: [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
takeDapResult [ErrMsg]
res = case (ErrMsg -> Bool) -> [ErrMsg] -> [ErrMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (ErrMsg -> ErrMsg -> Bool
U.startswith ErrMsg
_DAP_HEADER) [ErrMsg]
res of
  (ErrMsg
x:[]) -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b. (a -> b) -> a -> b
$ Int -> ErrMsg -> ErrMsg
forall a. Int -> [a] -> [a]
drop (ErrMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
_DAP_HEADER) ErrMsg
x
  [ErrMsg]
_ -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b. (a -> b) -> a -> b
$ ErrMsg
"invalid dap result from ghci. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ [ErrMsg] -> ErrMsg
forall a. Show a => a -> ErrMsg
show [ErrMsg]
res