{-# 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
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])
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
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
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
killGHCi :: AppContext ()
killGHCi :: AppContext ()
killGHCi = do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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
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"