{-# 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)
 -> (String -> AppContext (Maybe StateTransit))
 -> AppContext (Maybe StateTransit))
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext (Maybe StateTransit)
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError String -> 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 :: String
dap = String
":dap-set-breakpoints "
      cmd :: String
cmd = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetBreakpointsRequestArguments -> String
forall a. Show a => a -> String
U.showDAP SetBreakpointsRequestArguments
args
      dbg :: String
dbg = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetBreakpointsRequestArguments -> String
forall a. Show a => a -> String
show SetBreakpointsRequestArguments
args

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

  Maybe StateTransit -> AppContext (Maybe StateTransit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

  where
    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: String -> AppContext ()
dapHdl String
str = case String -> Either String (Either String SetBreakpointsResponseBody)
forall a. Read a => String -> Either String a
R.readEither String
str of
      Left String
err -> String -> AppContext (Maybe StateTransit)
errHdl String
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Left String
err) -> String -> AppContext (Maybe StateTransit)
errHdl String
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
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 {
                  seqSetBreakpointsResponse :: Int
DAP.seqSetBreakpointsResponse = Int
resSeq
                , request_seqSetBreakpointsResponse :: Int
DAP.request_seqSetBreakpointsResponse = SetBreakpointsRequest -> Int
DAP.seqSetBreakpointsRequest SetBreakpointsRequest
req
                , successSetBreakpointsResponse :: Bool
DAP.successSetBreakpointsResponse = Bool
True
                , bodySetBreakpointsResponse :: SetBreakpointsResponseBody
DAP.bodySetBreakpointsResponse = SetBreakpointsResponseBody
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 :: String -> AppContext (Maybe StateTransit)
errHdl String
msg = do
      String -> String -> AppContext ()
U.errorEV String
_LOG_APP String
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: SetBreakpointsResponse
res = SetBreakpointsResponse
DAP.defaultSetBreakpointsResponse {
                seqSetBreakpointsResponse :: Int
DAP.seqSetBreakpointsResponse = Int
resSeq
              , request_seqSetBreakpointsResponse :: Int
DAP.request_seqSetBreakpointsResponse = SetBreakpointsRequest -> Int
DAP.seqSetBreakpointsRequest SetBreakpointsRequest
req
              , successSetBreakpointsResponse :: Bool
DAP.successSetBreakpointsResponse = Bool
False
              , messageSetBreakpointsResponse :: String
DAP.messageSetBreakpointsResponse = String
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 (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 :: [String]
filters = SetExceptionBreakpointsRequestArguments -> [String]
DAP.filtersSetExceptionBreakpointsRequestArguments SetExceptionBreakpointsRequestArguments
args

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

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
  let res :: SetExceptionBreakpointsResponse
res = SetExceptionBreakpointsResponse
DAP.defaultSetExceptionBreakpointsResponse {
            seqSetExceptionBreakpointsResponse :: Int
DAP.seqSetExceptionBreakpointsResponse = Int
resSeq
          , request_seqSetExceptionBreakpointsResponse :: Int
DAP.request_seqSetExceptionBreakpointsResponse = SetExceptionBreakpointsRequest -> Int
DAP.seqSetExceptionBreakpointsRequest SetExceptionBreakpointsRequest
req
          , successSetExceptionBreakpointsResponse :: Bool
DAP.successSetExceptionBreakpointsResponse = Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

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

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

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



-- |
--
setFunctionBreakpointsRequest :: DAP.SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)
setFunctionBreakpointsRequest :: SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)
setFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req = (AppContext (Maybe StateTransit)
 -> (String -> AppContext (Maybe StateTransit))
 -> AppContext (Maybe StateTransit))
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext (Maybe StateTransit)
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError String -> 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 :: String
dap = String
":dap-set-function-breakpoints "
      cmd :: String
cmd = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetFunctionBreakpointsRequestArguments -> String
forall a. Show a => a -> String
U.showDAP SetFunctionBreakpointsRequestArguments
args
      dbg :: String
dbg = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ SetFunctionBreakpointsRequestArguments -> String
forall a. Show a => a -> String
show SetFunctionBreakpointsRequestArguments
args

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

  Maybe StateTransit -> AppContext (Maybe StateTransit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

  where

    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: String -> AppContext ()
dapHdl String
str = case String
-> Either String (Either String SetFunctionBreakpointsResponseBody)
forall a. Read a => String -> Either String a
R.readEither String
str of
      Left String
err -> String -> AppContext (Maybe StateTransit)
errHdl String
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Left String
err) -> String -> AppContext (Maybe StateTransit)
errHdl String
err AppContext (Maybe StateTransit) -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> AppContext ()
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 {
                  seqSetFunctionBreakpointsResponse :: Int
DAP.seqSetFunctionBreakpointsResponse = Int
resSeq
                , request_seqSetFunctionBreakpointsResponse :: Int
DAP.request_seqSetFunctionBreakpointsResponse = SetFunctionBreakpointsRequest -> Int
DAP.seqSetFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req
                , successSetFunctionBreakpointsResponse :: Bool
DAP.successSetFunctionBreakpointsResponse = Bool
True
                , bodySetFunctionBreakpointsResponse :: SetFunctionBreakpointsResponseBody
DAP.bodySetFunctionBreakpointsResponse = SetFunctionBreakpointsResponseBody
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 :: String -> AppContext (Maybe StateTransit)
errHdl String
msg = do
      String -> String -> AppContext ()
U.errorEV String
_LOG_APP String
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: SetFunctionBreakpointsResponse
res = SetFunctionBreakpointsResponse
DAP.defaultSetFunctionBreakpointsResponse {
                seqSetFunctionBreakpointsResponse :: Int
DAP.seqSetFunctionBreakpointsResponse = Int
resSeq
              , request_seqSetFunctionBreakpointsResponse :: Int
DAP.request_seqSetFunctionBreakpointsResponse = SetFunctionBreakpointsRequest -> Int
DAP.seqSetFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req
              , successSetFunctionBreakpointsResponse :: Bool
DAP.successSetFunctionBreakpointsResponse = Bool
False
              , messageSetFunctionBreakpointsResponse :: String
DAP.messageSetFunctionBreakpointsResponse = String
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing



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

  String -> AppContext ()
P.command String
cmd
  AppContext [String]
P.expectPmpt
  () -> AppContext ()
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 {
            seqDisconnectResponse :: Int
DAP.seqDisconnectResponse         = Int
resSeq
          , request_seqDisconnectResponse :: Int
DAP.request_seqDisconnectResponse = DisconnectRequest -> Int
DAP.seqDisconnectRequest DisconnectRequest
req
          , successDisconnectResponse :: Bool
DAP.successDisconnectResponse     = Bool
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 String IO) AppStores
-> StateT AppStores (ExceptT String IO) (MVar GHCiProc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT String 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> () -> AppContext ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> AppContext () -> (String -> AppContext ()) -> AppContext ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError AppContext ()
terminateGHCi (\String
_->() -> AppContext ()
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 :: String
dap = String
":dap-evaluate "
      cmd :: String
cmd = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ EvaluateRequestArguments -> String
forall a. Show a => a -> String
U.showDAP EvaluateRequestArguments
args
      dbg :: String
dbg = String
dap String -> String -> String
forall a. [a] -> [a] -> [a]
++ EvaluateRequestArguments -> String
forall a. Show a => a -> String
show EvaluateRequestArguments
args

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

  Maybe StateTransit -> AppContext (Maybe StateTransit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

  where

    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: String -> AppContext ()
dapHdl String
str = case String -> Either String (Either String EvaluateResponseBody)
forall a. Read a => String -> Either String a
R.readEither String
str of
      Left String
err -> String -> AppContext ()
errHdl (String -> AppContext ()) -> String -> AppContext ()
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
      Right (Left String
err) -> String -> AppContext ()
errHdl String
err
      Right (Right EvaluateResponseBody
body) -> do
        Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
        let res :: EvaluateResponse
res = EvaluateResponse
DAP.defaultEvaluateResponse {
                  seqEvaluateResponse :: Int
DAP.seqEvaluateResponse = Int
resSeq
                , request_seqEvaluateResponse :: Int
DAP.request_seqEvaluateResponse = EvaluateRequest -> Int
DAP.seqEvaluateRequest EvaluateRequest
req
                , successEvaluateResponse :: Bool
DAP.successEvaluateResponse = Bool
True
                , bodyEvaluateResponse :: EvaluateResponseBody
DAP.bodyEvaluateResponse = EvaluateResponseBody
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 :: String -> AppContext ()
errHdl String
msg = do
      String -> AppContext ()
U.sendErrorEventLF String
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: EvaluateResponse
res = EvaluateResponse
DAP.defaultEvaluateResponse {
                seqEvaluateResponse :: Int
DAP.seqEvaluateResponse = Int
resSeq
              , request_seqEvaluateResponse :: Int
DAP.request_seqEvaluateResponse = EvaluateRequest -> Int
DAP.seqEvaluateRequest EvaluateRequest
req
              , successEvaluateResponse :: Bool
DAP.successEvaluateResponse = Bool
False
              , messageEvaluateResponse :: String
DAP.messageEvaluateResponse = String
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)
 -> (String -> AppContext (Maybe StateTransit))
 -> AppContext (Maybe StateTransit))
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext (Maybe StateTransit)
-> (String -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError String -> 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 :: String
key  = CompletionsRequestArguments -> String
DAP.textCompletionsRequestArguments CompletionsRequestArguments
args
      size :: String
size = String
"0-50"
      cmd :: String
cmd = String
":complete repl " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

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

  Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
  let items :: [CompletionsItem]
items = [String] -> [CompletionsItem]
createItems [String]
outs
      body :: CompletionsResponseBody
body  = CompletionsResponseBody
DAP.defaultCompletionsResponseBody {
              targetsCompletionsResponseBody :: [CompletionsItem]
DAP.targetsCompletionsResponseBody = [CompletionsItem]
items
            }
      res :: CompletionsResponse
res = CompletionsResponse
DAP.defaultCompletionsResponse {
            seqCompletionsResponse :: Int
DAP.seqCompletionsResponse = Int
resSeq
          , request_seqCompletionsResponse :: Int
DAP.request_seqCompletionsResponse = CompletionsRequest -> Int
DAP.seqCompletionsRequest CompletionsRequest
req
          , successCompletionsResponse :: Bool
DAP.successCompletionsResponse = Bool
True
          , bodyCompletionsResponse :: CompletionsResponseBody
DAP.bodyCompletionsResponse = CompletionsResponseBody
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

  where
    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: String -> AppContext (Maybe StateTransit)
errHdl String
msg = do
      IO () -> AppContext ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.errorM String
_LOG_APP String
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: CompletionsResponse
res = CompletionsResponse
DAP.defaultCompletionsResponse {
                seqCompletionsResponse :: Int
DAP.seqCompletionsResponse = Int
resSeq
              , request_seqCompletionsResponse :: Int
DAP.request_seqCompletionsResponse = CompletionsRequest -> Int
DAP.seqCompletionsRequest CompletionsRequest
req
              , successCompletionsResponse :: Bool
DAP.successCompletionsResponse = Bool
False
              , messageCompletionsResponse :: String
DAP.messageCompletionsResponse = String
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

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

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

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

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



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

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

  () -> AppContext ()
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 {
            seqTerminateResponse :: Int
DAP.seqTerminateResponse         = Int
resSeq
          , request_seqTerminateResponse :: Int
DAP.request_seqTerminateResponse = TerminateRequest -> Int
DAP.seqTerminateRequest TerminateRequest
req
          , successTerminateResponse :: Bool
DAP.successTerminateResponse     = Bool
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 :: [String] -> StateT AppStores (ExceptT String IO) String
takeDapResult [String]
res = case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
U.startswith String
_DAP_HEADER) [String]
res of
  (String
x:[]) -> String -> StateT AppStores (ExceptT String IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT AppStores (ExceptT String IO) String)
-> String -> StateT AppStores (ExceptT String IO) String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
_DAP_HEADER) String
x
  [String]
_ -> String -> StateT AppStores (ExceptT String IO) String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> StateT AppStores (ExceptT String IO) String)
-> String -> StateT AppStores (ExceptT String IO) String
forall a b. (a -> b) -> a -> b
$ String
"invalid dap result from ghci. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
res