{-# LANGUAGE CPP #-}

module Haskell.Debug.Adapter.Utility where

import Control.Lens
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Conduit.Binary as C
import qualified Data.Conduit as C
import qualified Data.Conduit.List as C
import Control.Monad.Except
import Control.Monad.State.Lazy
import qualified System.IO as S
import qualified System.Process as S
import qualified System.Exit as S
import Control.Concurrent.MVar
import qualified System.Log.Logger as L
import qualified Data.List as L
import qualified Control.Exception.Safe as E

#if __GLASGOW_HASKELL__ >= 906
import Control.Monad
#endif

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant

-- |
--
str2bs :: String -> BS.ByteString
str2bs :: ErrMsg -> ByteString
str2bs = Text -> ByteString
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
T.pack

-- |
--
bs2str :: BS.ByteString -> String
bs2str :: ByteString -> ErrMsg
bs2str = Text -> ErrMsg
T.unpackforall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8

-- |
--
str2lbs :: String -> BSL.ByteString
str2lbs :: ErrMsg -> ByteString
str2lbs = Text -> ByteString
TLE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
TL.pack

-- |
--
lbs2str :: BSL.ByteString -> String
lbs2str :: ByteString -> ErrMsg
lbs2str = Text -> ErrMsg
TL.unpackforall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TLE.decodeUtf8


-- |
--
--
loadFile :: FilePath -> IO BS.ByteString
loadFile :: ErrMsg -> IO ByteString
loadFile ErrMsg
path = do
  [ByteString]
bs <- forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
ErrMsg -> ConduitT i ByteString m ()
C.sourceFile ErrMsg
path
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
C.consume
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString]
bs


-- |
--
--
saveFile :: FilePath -> BS.ByteString -> IO ()
saveFile :: ErrMsg -> ByteString -> IO ()
saveFile ErrMsg
path ByteString
cont = ErrMsg -> ByteString -> IO ()
saveFileBSL ErrMsg
path forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
cont


-- |
--
--
saveFileBSL :: FilePath -> BSL.ByteString -> IO ()
saveFileBSL :: ErrMsg -> ByteString -> IO ()
saveFileBSL ErrMsg
path ByteString
cont = forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
C.sourceLbs ByteString
cont
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) o.
MonadResource m =>
ErrMsg -> ConduitT ByteString o m ()
C.sinkFile ErrMsg
path


-- |
--
--
add2File :: FilePath -> BS.ByteString -> IO ()
add2File :: ErrMsg -> ByteString -> IO ()
add2File ErrMsg
path ByteString
cont = ErrMsg -> ByteString -> IO ()
add2FileBSL ErrMsg
path forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
cont

-- |
--
--
add2FileBSL :: FilePath -> BSL.ByteString -> IO ()
add2FileBSL :: ErrMsg -> ByteString -> IO ()
add2FileBSL ErrMsg
path ByteString
cont = forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
C.sourceLbs ByteString
cont
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) o.
MonadResource m =>
IO Handle -> ConduitT ByteString o m ()
C.sinkIOHandle IO Handle
hdl

  where hdl :: IO Handle
hdl = ErrMsg -> IOMode -> IO Handle
S.openFile ErrMsg
path IOMode
S.AppendMode


-- |
--  utility
--
showEE :: (Show e) => Either e a -> Either ErrMsg a
showEE :: forall e a. Show e => Either e a -> Either ErrMsg a
showEE (Right a
v) = forall a b. b -> Either a b
Right a
v
showEE (Left  e
e) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ErrMsg
show e
e


-- |
--
runApp :: AppStores -> AppContext a -> IO (Either ErrMsg (a, AppStores))
runApp :: forall a.
AppStores -> AppContext a -> IO (Either ErrMsg (a, AppStores))
runApp AppStores
dat AppContext a
app = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT AppContext a
app AppStores
dat


-- |
--
addRequest :: WrapRequest -> AppContext ()
addRequest :: WrapRequest -> AppContext ()
addRequest WrapRequest
req = do
  MVar [WrapRequest]
reqsMVar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  [WrapRequest]
reqs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
reqsMVar
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar ([WrapRequest]
reqsforall a. [a] -> [a] -> [a]
++[WrapRequest
req])


-- |
--  High priority
--
addRequestHP :: WrapRequest -> AppContext ()
addRequestHP :: WrapRequest -> AppContext ()
addRequestHP WrapRequest
req = do
  MVar [WrapRequest]
reqsMVar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  [WrapRequest]
reqs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
reqsMVar
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar (WrapRequest
reqforall a. a -> [a] -> [a]
:[WrapRequest]
reqs)


-- |
--
addResponse :: Response -> AppContext ()
addResponse :: Response -> AppContext ()
addResponse Response
res = do
  AppStores
appData <- forall s (m :: * -> *). MonadState s m => m s
get
  let mvar :: MVar [Response]
mvar = AppStores
appDataforall s a. s -> Getting a s a -> a
^.Lens' AppStores (MVar [Response])
resStoreAppStores
  [Response]
ress <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar [Response]
mvar
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar [Response]
mvar ([Response]
ressforall a. [a] -> [a] -> [a]
++[Response
res])


-- |
--
getIncreasedResponseSequence :: AppContext Int
getIncreasedResponseSequence :: AppContext Int
getIncreasedResponseSequence = do
  AppStores
appData <- forall s (m :: * -> *). MonadState s m => m s
get
  let cnt :: Int
cnt = AppStores
appDataforall s a. s -> Getting a s a -> a
^.Lens' AppStores Int
resSeqAppStores
      seq :: Int
seq = Int
1 forall a. Num a => a -> a -> a
+ Int
cnt
  forall s (m :: * -> *). MonadState s m => s -> m ()
put AppStores
appData {_resSeqAppStores :: Int
_resSeqAppStores = Int
seq}
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
seq

-- |
--
sendConsoleEvent :: String -> AppContext ()
sendConsoleEvent :: ErrMsg -> AppContext ()
sendConsoleEvent = ErrMsg -> ErrMsg -> AppContext ()
sendOutputEventWithType ErrMsg
"console"

-- |
--
sendConsoleEventLF :: String -> AppContext ()
sendConsoleEventLF :: ErrMsg -> AppContext ()
sendConsoleEventLF ErrMsg
x = ErrMsg -> AppContext ()
sendConsoleEvent (ErrMsg
x forall a. [a] -> [a] -> [a]
++ ErrMsg
_LF_STR)


-- |
--
sendStdoutEvent :: String -> AppContext ()
sendStdoutEvent :: ErrMsg -> AppContext ()
sendStdoutEvent = ErrMsg -> ErrMsg -> AppContext ()
sendOutputEventWithType ErrMsg
"stdout"


-- |
--
sendStdoutEventLF :: String -> AppContext ()
sendStdoutEventLF :: ErrMsg -> AppContext ()
sendStdoutEventLF ErrMsg
x = ErrMsg -> AppContext ()
sendStdoutEvent (ErrMsg
x forall a. [a] -> [a] -> [a]
++ ErrMsg
_LF_STR)


-- |
--
sendErrorEvent :: String -> AppContext ()
sendErrorEvent :: ErrMsg -> AppContext ()
sendErrorEvent = ErrMsg -> ErrMsg -> AppContext ()
sendOutputEventWithType ErrMsg
"stderr"

-- |
--
sendErrorEventLF :: String -> AppContext ()
sendErrorEventLF :: ErrMsg -> AppContext ()
sendErrorEventLF ErrMsg
x = ErrMsg -> AppContext ()
sendErrorEvent (ErrMsg
x forall a. [a] -> [a] -> [a]
++ ErrMsg
_LF_STR)


-- |
--
sendOutputEventWithType :: String -> String -> AppContext ()
sendOutputEventWithType :: ErrMsg -> ErrMsg -> AppContext ()
sendOutputEventWithType ErrMsg
evType ErrMsg
msg = do
  Int
resSeq <- AppContext Int
getIncreasedResponseSequence
  let body :: OutputEventBody
body = ErrMsg -> ErrMsg -> Maybe ErrMsg -> OutputEventBody
DAP.OutputEventBody ErrMsg
evType ErrMsg
msg forall a. Maybe a
Nothing
      outEvt :: OutputEvent
outEvt = OutputEvent
DAP.defaultOutputEvent {
                seqOutputEvent :: Int
DAP.seqOutputEvent = Int
resSeq
              , bodyOutputEvent :: OutputEventBody
DAP.bodyOutputEvent = OutputEventBody
body
              }

  Response -> AppContext ()
addResponse forall a b. (a -> b) -> a -> b
$ OutputEvent -> Response
OutputEvent OutputEvent
outEvt

-- |
--
debugEV :: String -> String -> AppContext ()
debugEV :: ErrMsg -> ErrMsg -> AppContext ()
debugEV ErrMsg
name ErrMsg
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
name ErrMsg
msg
  Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
L.DEBUG ErrMsg
name ErrMsg
msg

-- |
--
infoEV :: String -> String -> AppContext ()
infoEV :: ErrMsg -> ErrMsg -> AppContext ()
infoEV ErrMsg
name ErrMsg
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
name ErrMsg
msg
  Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
L.INFO ErrMsg
name ErrMsg
msg

-- |
--
warnEV :: String -> String -> AppContext ()
warnEV :: ErrMsg -> ErrMsg -> AppContext ()
warnEV ErrMsg
name ErrMsg
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.warningM ErrMsg
name ErrMsg
msg
  Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
L.WARNING ErrMsg
name ErrMsg
msg

-- |
--
errorEV :: String -> String -> AppContext ()
errorEV :: ErrMsg -> ErrMsg -> AppContext ()
errorEV ErrMsg
name ErrMsg
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.errorM ErrMsg
name ErrMsg
msg
  Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
L.ERROR ErrMsg
name ErrMsg
msg

-- |
--
criticalEV :: String -> String -> AppContext ()
criticalEV :: ErrMsg -> ErrMsg -> AppContext ()
criticalEV ErrMsg
name ErrMsg
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.criticalM ErrMsg
name ErrMsg
msg
  Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
L.CRITICAL ErrMsg
name ErrMsg
msg

-- |
--
logEV :: L.Priority -> String -> String -> AppContext ()
logEV :: Priority -> ErrMsg -> ErrMsg -> AppContext ()
logEV Priority
pr ErrMsg
name ErrMsg
msg = do
  MVar Priority
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar Priority)
logPriorityAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  Priority
logPR <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar Priority
mvar
  let msg' :: ErrMsg
msg' = if forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
_LF_STR ErrMsg
msg then ErrMsg
msg else ErrMsg
msg forall a. [a] -> [a] -> [a]
++ ErrMsg
_LF_STR

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
pr forall a. Ord a => a -> a -> Bool
>= Priority
logPR) forall a b. (a -> b) -> a -> b
$ do
    ErrMsg -> AppContext ()
sendStdoutEvent forall a b. (a -> b) -> a -> b
$ ErrMsg
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrMsg
show Priority
pr forall a. [a] -> [a] -> [a]
++ ErrMsg
"][" forall a. [a] -> [a] -> [a]
++ ErrMsg
name forall a. [a] -> [a] -> [a]
++ ErrMsg
"] " forall a. [a] -> [a] -> [a]
++ ErrMsg
msg'



-- |
--
sendPauseResponse :: DAP.PauseRequest -> AppContext ()
sendPauseResponse :: PauseRequest -> AppContext ()
sendPauseResponse PauseRequest
req = do
  Int
resSeq <- AppContext Int
getIncreasedResponseSequence

  let res :: PauseResponse
res = PauseResponse
DAP.defaultPauseResponse {
            seqPauseResponse :: Int
DAP.seqPauseResponse         = Int
resSeq
          , request_seqPauseResponse :: Int
DAP.request_seqPauseResponse = PauseRequest -> Int
DAP.seqPauseRequest PauseRequest
req
          , successPauseResponse :: Bool
DAP.successPauseResponse     = Bool
False
          , messagePauseResponse :: ErrMsg
DAP.messagePauseResponse     = ErrMsg
"pause request is not supported."
          }

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


-- |
--
--   phoityne -> haskell-dap
--   encoding RequestArgument to [Word8] because of using ghci command line interface.
--
showDAP :: Show a => a -> String
showDAP :: forall a. Show a => a -> ErrMsg
showDAP = forall a. Show a => a -> ErrMsg
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ErrMsg
show


-- |
--
sendTerminatedEvent :: AppContext ()
sendTerminatedEvent :: AppContext ()
sendTerminatedEvent = do
  Int
resSeq <- AppContext Int
getIncreasedResponseSequence
  let evt :: TerminatedEvent
evt = TerminatedEvent
DAP.defaultTerminatedEvent {
            seqTerminatedEvent :: Int
DAP.seqTerminatedEvent = Int
resSeq
          }

  Response -> AppContext ()
addResponse forall a b. (a -> b) -> a -> b
$ TerminatedEvent -> Response
TerminatedEvent TerminatedEvent
evt


-- |
--
sendRestartEvent :: AppContext ()
sendRestartEvent :: AppContext ()
sendRestartEvent = do
  Int
resSeq <- AppContext Int
getIncreasedResponseSequence
  let evt :: TerminatedEvent
evt = TerminatedEvent
DAP.defaultTerminatedEvent {
            seqTerminatedEvent :: Int
DAP.seqTerminatedEvent = Int
resSeq
          , bodyTerminatedEvent :: TerminatedEventBody
DAP.bodyTerminatedEvent = TerminatedEventBody
DAP.defaultTerminatedEventBody {
              restartTerminatedEventBody :: Bool
DAP.restartTerminatedEventBody = Bool
True
            }
          }

  Response -> AppContext ()
addResponse forall a b. (a -> b) -> a -> b
$ TerminatedEvent -> Response
TerminatedEvent TerminatedEvent
evt



-- |
--
sendExitedEvent :: AppContext ()
sendExitedEvent :: AppContext ()
sendExitedEvent = do
  Int
code <- AppContext Int
getExitCode
  Int
resSeq <- AppContext Int
getIncreasedResponseSequence
  let evt :: ExitedEvent
evt = ExitedEvent
DAP.defaultExitedEvent {
            seqExitedEvent :: Int
DAP.seqExitedEvent = Int
resSeq
          , bodyExitedEvent :: ExitedEventBody
DAP.bodyExitedEvent = ExitedEventBody
DAP.defaultExitedEventBody {
                exitCodeExitedEventBody :: Int
DAP.exitCodeExitedEventBody = Int
code
              }
          }

  Response -> AppContext ()
addResponse forall a b. (a -> b) -> a -> b
$ ExitedEvent -> Response
ExitedEvent ExitedEvent
evt

  where
    getExitCode :: AppContext Int
getExitCode = AppContext (Maybe Int)
getGHCiExitCode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Int
c -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
      Maybe Int
Nothing -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_NAME ErrMsg
"force kill ghci."
        AppContext Int
force

    force :: AppContext Int
force = AppContext ()
killGHCi forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AppContext (Maybe Int)
getGHCiExitCode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Int
c -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
      Maybe Int
Nothing -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_NAME ErrMsg
"force kill ghci failed."
        forall (m :: * -> *) a. Monad m => a -> m a
return Int
1  -- kill ghci failed. error exit anyway.

-- |
--
getGHCiExitCode :: AppContext (Maybe Int)
getGHCiExitCode :: AppContext (Maybe Int)
getGHCiExitCode = do
  MVar GHCiProc
procMVar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar GHCiProc)
ghciProcAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  GHCiProc
proc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar GHCiProc
procMVar
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO (Maybe ExitCode)
S.getProcessExitCode (GHCiProc
procforall s a. s -> Getting a s a -> a
^.Lens' GHCiProc ProcessHandle
procGHCiProc)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ExitCode
S.ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
0
    Just (S.ExitFailure Int
c) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
c
    Maybe ExitCode
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- |
--   On Windows, terminateProcess blocks for exiting.
--
killGHCi :: AppContext ()
killGHCi :: AppContext ()
killGHCi = do
  forall (m :: * -> *) a. Monad m => a -> m a
return ()
  {-
  procMVar <- view ghciProcAppStores <$> get
  proc <- liftIO $ readMVar procMVar
  liftIO $ S.terminateProcess (proc^.procGHCiProc)
  -}

-- |
--
handleStoppedEventBody :: DAP.StoppedEventBody -> AppContext ()
handleStoppedEventBody :: StoppedEventBody -> AppContext ()
handleStoppedEventBody StoppedEventBody
body
  | ErrMsg
"complete" forall a. Eq a => a -> a -> Bool
== StoppedEventBody -> ErrMsg
DAP.reasonStoppedEventBody StoppedEventBody
body = do
      ErrMsg -> AppContext ()
sendConsoleEventLF ErrMsg
"debugging completed. "
      Bool
isReRun <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores Bool
debugReRunableAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      Bool -> AppContext ()
handleReRun Bool
isReRun
  | Bool
otherwise = AppContext ()
sendStoppedEvent

  where
    handleReRun :: Bool -> AppContext ()
handleReRun Bool
True = do
      -- ghci and vscode can not rerun debugging without restart.
      -- sendContinuedEvent
      -- sendPauseEvent
      WrapRequest -> AppContext ()
addRequestHP forall a b. (a -> b) -> a -> b
$ forall a. Request a -> WrapRequest
WrapRequest
                   forall a b. (a -> b) -> a -> b
$ HdaInternalTransitRequest -> Request HdaInternalTransitRequest
InternalTransitRequest
                   forall a b. (a -> b) -> a -> b
$ StateTransit -> HdaInternalTransitRequest
HdaInternalTransitRequest StateTransit
DebugRun_Contaminated

    handleReRun Bool
False = do
      WrapRequest -> AppContext ()
addRequestHP forall a b. (a -> b) -> a -> b
$ forall a. Request a -> WrapRequest
WrapRequest
                   forall a b. (a -> b) -> a -> b
$ HdaInternalTerminateRequest -> Request HdaInternalTerminateRequest
InternalTerminateRequest
                   forall a b. (a -> b) -> a -> b
$ ErrMsg -> HdaInternalTerminateRequest
HdaInternalTerminateRequest ErrMsg
""

    sendStoppedEvent :: AppContext ()
sendStoppedEvent = do
      Int
resSeq <- AppContext Int
getIncreasedResponseSequence
      let res :: StoppedEvent
res = StoppedEvent
DAP.defaultStoppedEvent {
                seqStoppedEvent :: Int
DAP.seqStoppedEvent = Int
resSeq
              , bodyStoppedEvent :: StoppedEventBody
DAP.bodyStoppedEvent = StoppedEventBody
body
              }

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

{-
    sendContinuedEvent = do
      resSeq <- getIncreasedResponseSequence
      let res = DAP.defaultContinuedEvent {
                DAP.seqContinuedEvent = resSeq
              }

      addResponse $ ContinuedEvent res

    sendPauseEvent = do
      resSeq <- getIncreasedResponseSequence
      let res = DAP.defaultStoppedEvent {
                DAP.seqStoppedEvent = resSeq
              , DAP.bodyStoppedEvent = DAP.defaultStoppedEventBody {
                  DAP.reasonStoppedEventBody = "pause"
                }
              }

      addResponse $ StoppedEvent res
-}

-- |
--
readLine :: S.Handle -> AppContext String
readLine :: Handle -> AppContext ErrMsg
readLine Handle
hdl =   Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isOpenHdl Handle
hdl
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isReadableHdl
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isNotEofHdl
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> AppContext ErrMsg
go

  where
    go :: Handle -> AppContext ErrMsg
go Handle
hdl = forall a. IO a -> AppContext a
liftIOE forall a b. (a -> b) -> a -> b
$ Handle -> IO ErrMsg
S.hGetLine Handle
hdl


-- |
--
readChar :: S.Handle -> AppContext String
readChar :: Handle -> AppContext ErrMsg
readChar Handle
hdl = Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isOpenHdl Handle
hdl
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isReadableHdl
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isNotEofHdl
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Char
go
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}. Monad m => a -> m [a]
toString
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg -> AppContext ErrMsg
isNotEmpty

  where
    go :: Handle -> StateT AppStores (ExceptT ErrMsg IO) Char
go Handle
hdl = forall a. IO a -> AppContext a
liftIOE forall a b. (a -> b) -> a -> b
$ Handle -> IO Char
S.hGetChar Handle
hdl

    toString :: a -> m [a]
toString a
c = forall (m :: * -> *) a. Monad m => a -> m a
return [a
c]


-- |
--
readCharL :: S.Handle -> AppContext BSL.ByteString
readCharL :: Handle -> AppContext ByteString
readCharL Handle
hdl = Handle -> Int -> AppContext ByteString
readCharsL Handle
hdl Int
1


-- |
--
readCharsL :: S.Handle -> Int -> AppContext BSL.ByteString
readCharsL :: Handle -> Int -> AppContext ByteString
readCharsL Handle
hdl Int
c = Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isOpenHdl Handle
hdl
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isReadableHdl
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isNotEofHdl
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> AppContext ByteString
go
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> AppContext ByteString
isNotEmptyL

  where
    go :: Handle -> AppContext ByteString
go Handle
hdl = forall a. IO a -> AppContext a
liftIOE forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BSL.hGet Handle
hdl Int
c


-- |
--
isOpenHdl :: S.Handle -> AppContext S.Handle
isOpenHdl :: Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isOpenHdl Handle
rHdl = forall a. IO a -> AppContext a
liftIOE (Handle -> IO Bool
S.hIsOpen Handle
rHdl) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return Handle
rHdl
  Bool
False -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"invalid HANDLE. not opened."


-- |
--
isReadableHdl :: S.Handle -> AppContext S.Handle
isReadableHdl :: Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isReadableHdl Handle
rHdl = forall a. IO a -> AppContext a
liftIOE (Handle -> IO Bool
S.hIsReadable Handle
rHdl) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return Handle
rHdl
  Bool
False -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"invalid HANDLE. not readable."


-- |
--
isNotEofHdl :: S.Handle -> AppContext S.Handle
isNotEofHdl :: Handle -> StateT AppStores (ExceptT ErrMsg IO) Handle
isNotEofHdl Handle
rHdl = forall a. IO a -> AppContext a
liftIOE (Handle -> IO Bool
S.hIsEOF Handle
rHdl) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Handle
rHdl
  Bool
True  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"invalid HANDLE. eof."


-- |
--
isNotEmpty :: String -> AppContext String
isNotEmpty :: ErrMsg -> AppContext ErrMsg
isNotEmpty ErrMsg
b
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null ErrMsg
b = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"empty input."
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ErrMsg
b


-- |
--
isNotEmptyL :: BSL.ByteString -> AppContext BSL.ByteString
isNotEmptyL :: ByteString -> AppContext ByteString
isNotEmptyL ByteString
b
  | ByteString
b forall a. Eq a => a -> a -> Bool
== ByteString
BSL.empty = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"empty input."
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b


-- |
--
addEvent :: Event -> AppContext ()
addEvent :: Event -> AppContext ()
addEvent Event
evt = do
  MVar [Event]
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar [Event])
eventStoreAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  [Event]
evts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar [Event]
mvar
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar [Event]
mvar ([Event]
evtsforall a. [a] -> [a] -> [a]
++[Event
evt])


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE :: forall a. IO a -> AppContext a
liftIOE IO a
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall b. IO b -> IO (Either ErrMsg b)
go IO a
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
  where
    go :: IO b -> IO (Either String b)
    go :: forall b. IO b -> IO (Either ErrMsg b)
go IO b
f = forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
E.catchAny (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b
f) forall a. SomeException -> IO (Either ErrMsg a)
errHdl

    errHdl :: E.SomeException -> IO (Either String a)
    errHdl :: forall a. SomeException -> IO (Either ErrMsg a)
errHdl = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ErrMsg
show


-- |
--
rstrip :: String -> String
rstrip :: ErrMsg -> ErrMsg
rstrip = Text -> ErrMsg
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.stripEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
T.pack


-- |
--
strip :: String -> String
strip :: ErrMsg -> ErrMsg
strip = Text -> ErrMsg
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
T.pack

-- |
--
replace :: String -> String -> String -> String
replace :: ErrMsg -> ErrMsg -> ErrMsg -> ErrMsg
replace ErrMsg
a ErrMsg
b ErrMsg
c = Text -> ErrMsg
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace (ErrMsg -> Text
T.pack ErrMsg
a) (ErrMsg -> Text
T.pack ErrMsg
b) (ErrMsg -> Text
T.pack ErrMsg
c)

-- |
--
split :: String -> String -> [String]
split :: ErrMsg -> ErrMsg -> [ErrMsg]
split ErrMsg
a ErrMsg
b = forall a b. (a -> b) -> [a] -> [b]
map Text -> ErrMsg
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn (ErrMsg -> Text
T.pack ErrMsg
a) (ErrMsg -> Text
T.pack ErrMsg
b)

-- |
--
join :: String -> [String] -> String
join :: ErrMsg -> [ErrMsg] -> ErrMsg
join ErrMsg
a [ErrMsg]
b = Text -> ErrMsg
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate (ErrMsg -> Text
T.pack ErrMsg
a) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> Text
T.pack [ErrMsg]
b

-- |
--
startswith :: String -> String -> Bool
startswith :: ErrMsg -> ErrMsg -> Bool
startswith ErrMsg
a ErrMsg
b = Text -> Text -> Bool
T.isPrefixOf (ErrMsg -> Text
T.pack ErrMsg
a) (ErrMsg -> Text
T.pack ErrMsg
b)


-- |
--
stdioLogging :: BSL.ByteString -> AppContext ()
stdioLogging :: ByteString -> AppContext ()
stdioLogging ByteString
bs = do
  Maybe ErrMsg
logFile <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (Maybe ErrMsg)
stdioLogFileAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  Maybe ErrMsg -> AppContext ()
go Maybe ErrMsg
logFile

  where
    go :: Maybe FilePath -> AppContext ()
    go :: Maybe ErrMsg -> AppContext ()
go Maybe ErrMsg
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (Just ErrMsg
f) = forall a. IO a -> AppContext a
liftIOE forall a b. (a -> b) -> a -> b
$ ErrMsg -> ByteString -> IO ()
BSL.appendFile ErrMsg
f ByteString
bs


-- |
--
stdinLogging :: BSL.ByteString -> AppContext ()
stdinLogging :: ByteString -> AppContext ()
stdinLogging ByteString
bs = do
  ByteString -> AppContext ()
stdioLogging forall a b. (a -> b) -> a -> b
$ ErrMsg -> ByteString
str2lbs ErrMsg
"[ IN]" ByteString -> ByteString -> ByteString
`BSL.append` ByteString
bs ByteString -> ByteString -> ByteString
`BSL.append` ErrMsg -> ByteString
str2lbs ErrMsg
"\n"


-- |
--
stdoutLogging :: BSL.ByteString -> AppContext ()
stdoutLogging :: ByteString -> AppContext ()
stdoutLogging ByteString
bs = do
  ByteString -> AppContext ()
stdioLogging forall a b. (a -> b) -> a -> b
$ ErrMsg -> ByteString
str2lbs ErrMsg
"[OUT]" ByteString -> ByteString -> ByteString
`BSL.append` ByteString
bs ByteString -> ByteString -> ByteString
`BSL.append` ErrMsg -> ByteString
str2lbs ErrMsg
"\n"