{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}

module Haskell.Debug.Adapter.GHCi where

import Control.Monad.IO.Class
import Control.Lens
import qualified Data.ByteString as B
import Control.Concurrent.MVar
import Control.Monad.State.Lazy
import Control.Monad.Except
import GHC.IO.Encoding
import Distribution.System
import qualified System.Process as S
import qualified System.IO as S
import qualified System.Environment as S
import qualified Data.Map as M
import qualified Data.List as L

import Haskell.Debug.Adapter.Type
import qualified Haskell.Debug.Adapter.Utility as U
import Haskell.Debug.Adapter.Constant

#if __GLASGOW_HASKELL__ >= 906
import Control.Monad
#endif
---------------------------------------------------------------------------------
-- |
--  run ghci.
--
startGHCi :: String
          -> [String]
          -> FilePath
          -> M.Map String String
          -> AppContext ()
startGHCi :: ErrMsg -> [ErrMsg] -> ErrMsg -> Map ErrMsg ErrMsg -> AppContext ()
startGHCi ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs =
  IO (Either ErrMsg GHCiProc) -> AppContext (Either ErrMsg GHCiProc)
forall a. IO a -> AppContext a
U.liftIOE (ErrMsg
-> [ErrMsg]
-> ErrMsg
-> Map ErrMsg ErrMsg
-> IO (Either ErrMsg GHCiProc)
startGHCiIO ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs) AppContext (Either ErrMsg GHCiProc)
-> (Either ErrMsg GHCiProc
    -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc)
-> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
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
>>= Either ErrMsg GHCiProc
-> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither StateT AppStores (ExceptT ErrMsg IO) GHCiProc
-> (GHCiProc -> 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
>>= GHCiProc -> AppContext ()
forall {m :: * -> *}.
(MonadState AppStores m, MonadIO m) =>
GHCiProc -> m ()
updateGHCi

  where
    updateGHCi :: GHCiProc -> m ()
updateGHCi GHCiProc
proc = do
      MVar GHCiProc
mvar <- 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) -> m AppStores -> m (MVar GHCiProc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m AppStores
forall s (m :: * -> *). MonadState s m => m s
get
      --_ <- liftIO $ takeMVar mvar
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar GHCiProc -> GHCiProc -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar GHCiProc
mvar GHCiProc
proc


-- |
--
startGHCiIO :: String
            -> [String]
            -> FilePath
            -> M.Map String String
            -> IO (Either ErrMsg GHCiProc)
startGHCiIO :: ErrMsg
-> [ErrMsg]
-> ErrMsg
-> Map ErrMsg ErrMsg
-> IO (Either ErrMsg GHCiProc)
startGHCiIO ErrMsg
cmd [ErrMsg]
opts ErrMsg
cwd Map ErrMsg ErrMsg
envs = do

  (Handle
fromPhoityneHandle, Handle
toGHCiHandle) <- IO (Handle, Handle)
S.createPipe
  (Handle
fromGHCiHandle, Handle
toPhoityneHandle) <- IO (Handle, Handle)
S.createPipe

  TextEncoding
osEnc <- IO TextEncoding
getReadHandleEncoding

  let bufMode :: BufferMode
bufMode = BufferMode
S.NoBuffering
  --let bufMode = S.BlockBuffering $ Just 1024

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
toPhoityneHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
toPhoityneHandle TextEncoding
osEnc
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
toPhoityneHandle (NewlineMode -> IO ()) -> NewlineMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.CRLF Newline
S.LF
  --S.hSetBinaryMode toPhoityneHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
fromPhoityneHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
fromPhoityneHandle  TextEncoding
S.utf8
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
fromPhoityneHandle (NewlineMode -> IO ()) -> NewlineMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.LF Newline
S.LF
  --S.hSetBinaryMode fromPhoityneHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
toGHCiHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
toGHCiHandle TextEncoding
S.utf8
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
toGHCiHandle (NewlineMode -> IO ()) -> NewlineMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.LF Newline
S.LF
  --S.hSetBinaryMode toGHCiHandle True

  Handle -> BufferMode -> IO ()
S.hSetBuffering Handle
fromGHCiHandle BufferMode
bufMode
  Handle -> TextEncoding -> IO ()
S.hSetEncoding Handle
fromGHCiHandle TextEncoding
osEnc
  Handle -> NewlineMode -> IO ()
S.hSetNewlineMode Handle
fromGHCiHandle (NewlineMode -> IO ()) -> NewlineMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Newline -> Newline -> NewlineMode
S.NewlineMode Newline
S.CRLF Newline
S.LF
  --S.hSetBinaryMode fromGHCiHandle True

  Maybe [(ErrMsg, ErrMsg)]
runEnvs <- IO (Maybe [(ErrMsg, ErrMsg)])
getRunEnv

  ProcessHandle
ghciGHCi <- ErrMsg
-> [ErrMsg]
-> Maybe ErrMsg
-> Maybe [(ErrMsg, ErrMsg)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
S.runProcess ErrMsg
cmd [ErrMsg]
opts (ErrMsg -> Maybe ErrMsg
forall a. a -> Maybe a
Just ErrMsg
cwd) Maybe [(ErrMsg, ErrMsg)]
runEnvs (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
fromPhoityneHandle) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
toPhoityneHandle) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
toPhoityneHandle)

  Either ErrMsg GHCiProc -> IO (Either ErrMsg GHCiProc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrMsg GHCiProc -> IO (Either ErrMsg GHCiProc))
-> (GHCiProc -> Either ErrMsg GHCiProc)
-> GHCiProc
-> IO (Either ErrMsg GHCiProc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCiProc -> Either ErrMsg GHCiProc
forall a b. b -> Either a b
Right (GHCiProc -> IO (Either ErrMsg GHCiProc))
-> GHCiProc -> IO (Either ErrMsg GHCiProc)
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Handle -> ProcessHandle -> GHCiProc
GHCiProc Handle
toGHCiHandle Handle
fromGHCiHandle Handle
fromGHCiHandle ProcessHandle
ghciGHCi

  where
    -- |
    --
    getReadHandleEncoding :: IO TextEncoding
    getReadHandleEncoding :: IO TextEncoding
getReadHandleEncoding = if
      | OS
Windows OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
buildOS -> ErrMsg -> IO TextEncoding
mkTextEncoding ErrMsg
"CP932//TRANSLIT"
      | Bool
otherwise          -> ErrMsg -> IO TextEncoding
mkTextEncoding ErrMsg
"UTF-8//TRANSLIT"

    -- |
    --
    getRunEnv :: IO (Maybe [(ErrMsg, ErrMsg)])
getRunEnv
      | Map ErrMsg ErrMsg -> Bool
forall a. Map ErrMsg a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ErrMsg ErrMsg
envs = Maybe [(ErrMsg, ErrMsg)] -> IO (Maybe [(ErrMsg, ErrMsg)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(ErrMsg, ErrMsg)]
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          [(ErrMsg, ErrMsg)]
curEnvs <- IO [(ErrMsg, ErrMsg)]
S.getEnvironment
          Maybe [(ErrMsg, ErrMsg)] -> IO (Maybe [(ErrMsg, ErrMsg)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(ErrMsg, ErrMsg)] -> IO (Maybe [(ErrMsg, ErrMsg)]))
-> Maybe [(ErrMsg, ErrMsg)] -> IO (Maybe [(ErrMsg, ErrMsg)])
forall a b. (a -> b) -> a -> b
$ [(ErrMsg, ErrMsg)] -> Maybe [(ErrMsg, ErrMsg)]
forall a. a -> Maybe a
Just ([(ErrMsg, ErrMsg)] -> Maybe [(ErrMsg, ErrMsg)])
-> [(ErrMsg, ErrMsg)] -> Maybe [(ErrMsg, ErrMsg)]
forall a b. (a -> b) -> a -> b
$ Map ErrMsg ErrMsg -> [(ErrMsg, ErrMsg)]
forall k a. Map k a -> [(k, a)]
M.toList Map ErrMsg ErrMsg
envs [(ErrMsg, ErrMsg)] -> [(ErrMsg, ErrMsg)] -> [(ErrMsg, ErrMsg)]
forall a. [a] -> [a] -> [a]
++ [(ErrMsg, ErrMsg)]
curEnvs


-- |
--  write to ghci.
--
command :: String -> AppContext ()
command :: ErrMsg -> AppContext ()
command ErrMsg
cmd = 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
  GHCiProc
proc <- IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a. IO a -> AppContext a
U.liftIOE (IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc)
-> IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a b. (a -> b) -> a -> b
$ MVar GHCiProc -> IO GHCiProc
forall a. MVar a -> IO a
readMVar MVar GHCiProc
mver
  let hdl :: Handle
hdl = GHCiProc
procGHCiProc -> Getting Handle GHCiProc Handle -> Handle
forall s a. s -> Getting a s a -> a
^.Getting Handle GHCiProc Handle
Lens' GHCiProc Handle
wHdLGHCiProc

  IO () -> AppContext ()
forall a. IO a -> AppContext a
U.liftIOE (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ Handle -> ErrMsg -> IO ()
S.hPutStrLn Handle
hdl ErrMsg
cmd
  ErrMsg -> AppContext ()
pout ErrMsg
cmd

  where
    pout :: ErrMsg -> AppContext ()
pout ErrMsg
s
      | ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf ErrMsg
":dap-" ErrMsg
s = ErrMsg -> AppContext ()
U.sendStdoutEventLF (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ((Char -> Bool) -> ErrMsg -> ErrMsg
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Char
' ') ErrMsg
s) ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" ..."
      | Bool
otherwise = ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
s


-- |
--
expectInitPmpt :: String -> AppContext [String]
expectInitPmpt :: ErrMsg -> AppContext [ErrMsg]
expectInitPmpt ErrMsg
pmpt = do
  MVar GHCiProc
mvar <- 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
  GHCiProc
proc <- IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a. IO a -> AppContext a
U.liftIOE (IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc)
-> IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a b. (a -> b) -> a -> b
$ MVar GHCiProc -> IO GHCiProc
forall a. MVar a -> IO a
readMVar MVar GHCiProc
mvar
  let hdl :: Handle
hdl = GHCiProc
procGHCiProc -> Getting Handle GHCiProc Handle -> Handle
forall s a. s -> Getting a s a -> a
^.Getting Handle GHCiProc Handle
Lens' GHCiProc Handle
rHdlGHCiProc

  ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
pmpt Handle
hdl ErrMsg
"" AppContext (Either ErrMsg ErrMsg)
-> (Either ErrMsg ErrMsg -> AppContext [ErrMsg])
-> AppContext [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
>>= \case
    Right ErrMsg
xs -> do
      let strs :: [ErrMsg]
strs = (ErrMsg -> ErrMsg) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> ErrMsg
U.rstrip ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg]
lines ErrMsg
xs
      [ErrMsg] -> AppContext ()
pout [ErrMsg]
strs
      [ErrMsg] -> AppContext [ErrMsg]
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
strs
    Left ErrMsg
xs -> do
      let strs :: [ErrMsg]
strs = (ErrMsg -> ErrMsg) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> ErrMsg
U.rstrip ([ErrMsg] -> [ErrMsg]) -> [ErrMsg] -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ ErrMsg -> [ErrMsg]
lines ErrMsg
xs
      [ErrMsg] -> AppContext ()
pout [ErrMsg]
strs
      ErrMsg -> AppContext [ErrMsg]
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"[CRITICAL] can not get the initial ghci prompt."

  where
    go :: String -> S.Handle -> String -> AppContext (Either String String)
    go :: ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
key Handle
hdl ErrMsg
acc = AppContext (Either ErrMsg ErrMsg)
-> (ErrMsg -> AppContext (Either ErrMsg ErrMsg))
-> AppContext (Either ErrMsg ErrMsg)
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
      (Handle -> AppContext ErrMsg
U.readChar Handle
hdl AppContext ErrMsg
-> (ErrMsg -> AppContext (Either ErrMsg ErrMsg))
-> AppContext (Either ErrMsg 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
-> Handle -> ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
byPmpt ErrMsg
key Handle
hdl ErrMsg
acc)
      (ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
errHdl ErrMsg
acc)

    errHdl :: String -> String -> AppContext (Either String String)
    errHdl :: ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
errHdl ErrMsg
acc ErrMsg
e = Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg))
-> Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> Either ErrMsg ErrMsg
forall a b. a -> Either a b
Left (ErrMsg -> Either ErrMsg ErrMsg) -> ErrMsg -> Either ErrMsg ErrMsg
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> ErrMsg
unlines [ErrMsg
acc, ErrMsg
"", ErrMsg
e, ErrMsg
""]

    byPmpt :: String -> S.Handle -> String -> String -> AppContext (Either String String)
    byPmpt :: ErrMsg
-> Handle -> ErrMsg -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
byPmpt ErrMsg
key Handle
hdl ErrMsg
acc ErrMsg
b = do
      let newAcc :: ErrMsg
newAcc = ErrMsg
acc ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
b
      ErrMsg -> ErrMsg -> AppContext ()
U.debugEV ErrMsg
_LOG_GHCI_STDOUT ErrMsg
newAcc
      if ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
key ErrMsg
newAcc
        then Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg))
-> Either ErrMsg ErrMsg -> AppContext (Either ErrMsg ErrMsg)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> Either ErrMsg ErrMsg
forall a b. b -> Either a b
Right ErrMsg
newAcc
        else ErrMsg -> Handle -> ErrMsg -> AppContext (Either ErrMsg ErrMsg)
go ErrMsg
key Handle
hdl ErrMsg
newAcc

    pout :: [ErrMsg] -> AppContext ()
pout [] = () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    pout (ErrMsg
x:[]) = ErrMsg -> AppContext ()
U.sendStdoutEvent ErrMsg
x
    pout (ErrMsg
x:[ErrMsg]
xs) = ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
x AppContext () -> 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
>> [ErrMsg] -> AppContext ()
pout [ErrMsg]
xs

-- |
--
expectPmpt :: AppContext [String]
expectPmpt :: AppContext [ErrMsg]
expectPmpt = do
  ErrMsg
pmpt <- 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
-> AppContext 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
  MVar GHCiProc
mvar <- 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
  GHCiProc
proc <- IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a. IO a -> AppContext a
U.liftIOE (IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc)
-> IO GHCiProc -> StateT AppStores (ExceptT ErrMsg IO) GHCiProc
forall a b. (a -> b) -> a -> b
$ MVar GHCiProc -> IO GHCiProc
forall a. MVar a -> IO a
readMVar MVar GHCiProc
mvar
  let hdl :: Handle
hdl = GHCiProc
procGHCiProc -> Getting Handle GHCiProc Handle -> Handle
forall s a. s -> Getting a s a -> a
^.Getting Handle GHCiProc Handle
Lens' GHCiProc Handle
rHdlGHCiProc
      plen :: Int
plen = ErrMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
pmpt

  Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl []

  where
    go :: Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl [ErrMsg]
acc = IO Bool -> AppContext Bool
forall a. IO a -> AppContext a
U.liftIOE (Handle -> IO Bool
S.hIsEOF Handle
hdl) AppContext Bool
-> (Bool -> AppContext [ErrMsg]) -> AppContext [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
>>= \case
      Bool
True  -> [ErrMsg] -> AppContext [ErrMsg]
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrMsg]
acc
      Bool
False -> Handle -> AppContext ErrMsg
U.readLine Handle
hdl AppContext ErrMsg
-> (ErrMsg -> AppContext [ErrMsg]) -> AppContext [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
>>= Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
byLine Int
plen Handle
hdl [ErrMsg]
acc

    byLine :: Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
byLine Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
line
      | ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
_DAP_CMD_END2 ErrMsg
line = Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
goEnd Int
plen Handle
hdl [ErrMsg]
acc
      | Bool
otherwise = Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
cont Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
line

    cont :: Int -> Handle -> [ErrMsg] -> ErrMsg -> AppContext [ErrMsg]
cont Int
plen Handle
hdl [ErrMsg]
acc ErrMsg
l = do
      Bool -> AppContext () -> AppContext ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (ErrMsg -> ErrMsg -> Bool
U.startswith ErrMsg
_DAP_HEADER ErrMsg
l)) (AppContext () -> AppContext ()) -> AppContext () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> AppContext ()
U.sendStdoutEventLF ErrMsg
l
      Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
go Int
plen Handle
hdl ([ErrMsg] -> AppContext [ErrMsg])
-> [ErrMsg] -> AppContext [ErrMsg]
forall a b. (a -> b) -> a -> b
$ [ErrMsg]
acc [ErrMsg] -> [ErrMsg] -> [ErrMsg]
forall a. [a] -> [a] -> [a]
++ [ErrMsg
l]

    goEnd :: Int -> Handle -> [ErrMsg] -> AppContext [ErrMsg]
goEnd Int
plen Handle
hdl [ErrMsg]
acc = do
      ByteString
b <- IO ByteString -> AppContext ByteString
forall a. IO a -> AppContext a
U.liftIOE (IO ByteString -> AppContext ByteString)
-> IO ByteString -> AppContext ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
hdl Int
plen
      let l :: ErrMsg
l = ByteString -> ErrMsg
U.bs2str ByteString
b
      ErrMsg -> AppContext ()
U.sendStdoutEvent ErrMsg
l
      [ErrMsg] -> AppContext [ErrMsg]
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrMsg] -> AppContext [ErrMsg])
-> [ErrMsg] -> AppContext [ErrMsg]
forall a b. (a -> b) -> a -> b
$ [ErrMsg]
acc [ErrMsg] -> [ErrMsg] -> [ErrMsg]
forall a. [a] -> [a] -> [a]
++ [ErrMsg
l]