{-# 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 (Text -> ByteString) -> (ErrMsg -> Text) -> ErrMsg -> ByteString
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.unpack(Text -> ErrMsg) -> (ByteString -> Text) -> ByteString -> ErrMsg
forall 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 (Text -> ByteString) -> (ErrMsg -> Text) -> ErrMsg -> ByteString
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.unpack(Text -> ErrMsg) -> (ByteString -> Text) -> ByteString -> ErrMsg
forall 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 <- ConduitT () Void (ResourceT IO) [ByteString] -> IO [ByteString]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
      (ConduitT () Void (ResourceT IO) [ByteString] -> IO [ByteString])
-> ConduitT () Void (ResourceT IO) [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
MonadResource m =>
ErrMsg -> ConduitT i ByteString m ()
C.sourceFile ErrMsg
path
      ConduitT () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) [ByteString]
-> ConduitT () Void (ResourceT IO) [ByteString]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| ConduitT ByteString Void (ResourceT IO) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
C.consume
  ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
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 (ByteString -> IO ()) -> ByteString -> IO ()
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 = ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
  (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
C.sourceLbs ByteString
cont
  ConduitT () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| ErrMsg -> ConduitT ByteString Void (ResourceT IO) ()
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 (ByteString -> IO ()) -> ByteString -> IO ()
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 = ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
C.runConduitRes
  (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
C.sourceLbs ByteString
cont
  ConduitT () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| IO Handle -> ConduitT ByteString Void (ResourceT IO) ()
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) = a -> Either ErrMsg a
forall a b. b -> Either a b
Right a
v
showEE (Left  e
e) = ErrMsg -> Either ErrMsg a
forall a b. a -> Either a b
Left (ErrMsg -> Either ErrMsg a) -> ErrMsg -> Either ErrMsg a
forall a b. (a -> b) -> a -> b
$ e -> ErrMsg
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 = ExceptT ErrMsg IO (a, AppStores)
-> IO (Either ErrMsg (a, AppStores))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrMsg IO (a, AppStores)
 -> IO (Either ErrMsg (a, AppStores)))
-> ExceptT ErrMsg IO (a, AppStores)
-> IO (Either ErrMsg (a, AppStores))
forall a b. (a -> b) -> a -> b
$ AppContext a -> AppStores -> ExceptT ErrMsg IO (a, AppStores)
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 <- Getting (MVar [WrapRequest]) AppStores (MVar [WrapRequest])
-> AppStores -> MVar [WrapRequest]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar [WrapRequest]) AppStores (MVar [WrapRequest])
Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores (AppStores -> MVar [WrapRequest])
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar [WrapRequest])
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
  [WrapRequest]
reqs <- IO [WrapRequest]
-> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest]
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [WrapRequest]
 -> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest])
-> IO [WrapRequest]
-> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest]
forall a b. (a -> b) -> a -> b
$ MVar [WrapRequest] -> IO [WrapRequest]
forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
reqsMVar
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ MVar [WrapRequest] -> [WrapRequest] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar ([WrapRequest]
reqs[WrapRequest] -> [WrapRequest] -> [WrapRequest]
forall a. [a] -> [a] -> [a]
++[WrapRequest
req])


-- |
--  High priority
--
addRequestHP :: WrapRequest -> AppContext ()
addRequestHP :: WrapRequest -> AppContext ()
addRequestHP WrapRequest
req = do
  MVar [WrapRequest]
reqsMVar <- Getting (MVar [WrapRequest]) AppStores (MVar [WrapRequest])
-> AppStores -> MVar [WrapRequest]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar [WrapRequest]) AppStores (MVar [WrapRequest])
Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores (AppStores -> MVar [WrapRequest])
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar [WrapRequest])
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
  [WrapRequest]
reqs <- IO [WrapRequest]
-> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest]
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [WrapRequest]
 -> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest])
-> IO [WrapRequest]
-> StateT AppStores (ExceptT ErrMsg IO) [WrapRequest]
forall a b. (a -> b) -> a -> b
$ MVar [WrapRequest] -> IO [WrapRequest]
forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
reqsMVar
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ MVar [WrapRequest] -> [WrapRequest] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar (WrapRequest
reqWrapRequest -> [WrapRequest] -> [WrapRequest]
forall a. a -> [a] -> [a]
:[WrapRequest]
reqs)


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


-- |
--
getIncreasedResponseSequence :: AppContext Int
getIncreasedResponseSequence :: AppContext Int
getIncreasedResponseSequence = do
  AppStores
appData <- StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  let cnt :: Int
cnt = AppStores
appDataAppStores -> Getting Int AppStores Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int AppStores Int
Lens' AppStores Int
resSeqAppStores
      seq :: Int
seq = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cnt
  AppStores -> AppContext ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppStores
appData {_resSeqAppStores = seq}
  Int -> AppContext Int
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
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 ErrMsg -> ErrMsg -> ErrMsg
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 ErrMsg -> ErrMsg -> ErrMsg
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 ErrMsg -> ErrMsg -> ErrMsg
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 Maybe ErrMsg
forall a. Maybe a
Nothing
      outEvt :: OutputEvent
outEvt = OutputEvent
DAP.defaultOutputEvent {
                DAP.seqOutputEvent = resSeq
              , DAP.bodyOutputEvent = body
              }

  Response -> AppContext ()
addResponse (Response -> AppContext ()) -> Response -> AppContext ()
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
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.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
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.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
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.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
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.errorM ErrMsg
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
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.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 <- Getting (MVar Priority) AppStores (MVar Priority)
-> AppStores -> MVar Priority
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar Priority) AppStores (MVar Priority)
Lens' AppStores (MVar Priority)
logPriorityAppStores (AppStores -> MVar Priority)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar Priority)
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
  Priority
logPR <- IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority)
-> IO Priority -> StateT AppStores (ExceptT ErrMsg IO) Priority
forall a b. (a -> b) -> a -> b
$ MVar Priority -> IO Priority
forall a. MVar a -> IO a
readMVar MVar Priority
mvar
  let msg' :: ErrMsg
msg' = if ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
_LF_STR ErrMsg
msg then ErrMsg
msg else ErrMsg
msg ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
_LF_STR

  Bool -> AppContext () -> AppContext ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
pr Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
logPR) (AppContext () -> AppContext ()) -> AppContext () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ do
    ErrMsg -> AppContext ()
sendStdoutEvent (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"[" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ Priority -> ErrMsg
forall a. Show a => a -> ErrMsg
show Priority
pr ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"][" ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
name ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
"] " ErrMsg -> ErrMsg -> 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 {
            DAP.seqPauseResponse         = resSeq
          , DAP.request_seqPauseResponse = DAP.seqPauseRequest req
          , DAP.successPauseResponse     = False
          , DAP.messagePauseResponse     = "pause request is not supported."
          }

  Response -> AppContext ()
addResponse (Response -> AppContext ()) -> Response -> AppContext ()
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 = [Word8] -> ErrMsg
forall a. Show a => a -> ErrMsg
show ([Word8] -> ErrMsg) -> (a -> [Word8]) -> a -> ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> (a -> ByteString) -> a -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Text
T.pack (ErrMsg -> Text) -> (a -> ErrMsg) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrMsg
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 {
            DAP.seqTerminatedEvent = resSeq
          }

  Response -> AppContext ()
addResponse (Response -> AppContext ()) -> Response -> AppContext ()
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 {
            DAP.seqTerminatedEvent = resSeq
          , DAP.bodyTerminatedEvent = DAP.defaultTerminatedEventBody {
              DAP.restartTerminatedEventBody = True
            }
          }

  Response -> AppContext ()
addResponse (Response -> AppContext ()) -> Response -> AppContext ()
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 {
            DAP.seqExitedEvent = resSeq
          , DAP.bodyExitedEvent = DAP.defaultExitedEventBody {
                DAP.exitCodeExitedEventBody = code
              }
          }

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

  where
    getExitCode :: AppContext Int
getExitCode = AppContext (Maybe Int)
getGHCiExitCode AppContext (Maybe Int)
-> (Maybe Int -> AppContext Int) -> AppContext Int
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
      Just Int
c -> Int -> AppContext Int
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
      Maybe Int
Nothing -> do
        IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_NAME ErrMsg
"force kill ghci."
        AppContext Int
force

    force :: AppContext Int
force = AppContext ()
killGHCi AppContext () -> AppContext (Maybe Int) -> AppContext (Maybe Int)
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AppContext (Maybe Int)
getGHCiExitCode AppContext (Maybe Int)
-> (Maybe Int -> AppContext Int) -> AppContext Int
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
      Just Int
c -> Int -> AppContext Int
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
c
      Maybe Int
Nothing -> do
        IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_NAME ErrMsg
"force kill ghci failed."
        Int -> AppContext Int
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
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 <- 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 -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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
procMVar
  IO (Maybe ExitCode)
-> StateT AppStores (ExceptT ErrMsg IO) (Maybe ExitCode)
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO (Maybe ExitCode)
S.getProcessExitCode (GHCiProc
procGHCiProc
-> Getting ProcessHandle GHCiProc ProcessHandle -> ProcessHandle
forall s a. s -> Getting a s a -> a
^.Getting ProcessHandle GHCiProc ProcessHandle
Lens' GHCiProc ProcessHandle
procGHCiProc)) StateT AppStores (ExceptT ErrMsg IO) (Maybe ExitCode)
-> (Maybe ExitCode -> AppContext (Maybe Int))
-> AppContext (Maybe Int)
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
    Just ExitCode
S.ExitSuccess -> Maybe Int -> AppContext (Maybe Int)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> AppContext (Maybe Int))
-> Maybe Int -> AppContext (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
    Just (S.ExitFailure Int
c) -> Maybe Int -> AppContext (Maybe Int)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> AppContext (Maybe Int))
-> Maybe Int -> AppContext (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
c
    Maybe ExitCode
Nothing -> Maybe Int -> AppContext (Maybe Int)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing

-- |
--   On Windows, terminateProcess blocks for exiting.
--
killGHCi :: AppContext ()
killGHCi :: AppContext ()
killGHCi = do
  () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
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" ErrMsg -> ErrMsg -> Bool
forall a. Eq a => a -> a -> Bool
== StoppedEventBody -> ErrMsg
DAP.reasonStoppedEventBody StoppedEventBody
body = do
      ErrMsg -> AppContext ()
sendConsoleEventLF ErrMsg
"debugging completed. "
      Bool
isReRun <- Getting Bool AppStores Bool -> AppStores -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool AppStores Bool
Lens' AppStores Bool
debugReRunableAppStores (AppStores -> Bool)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) Bool
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
      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 (WrapRequest -> AppContext ()) -> WrapRequest -> AppContext ()
forall a b. (a -> b) -> a -> b
$ Request HdaInternalTransitRequest -> WrapRequest
forall a. Request a -> WrapRequest
WrapRequest
                   (Request HdaInternalTransitRequest -> WrapRequest)
-> Request HdaInternalTransitRequest -> WrapRequest
forall a b. (a -> b) -> a -> b
$ HdaInternalTransitRequest -> Request HdaInternalTransitRequest
InternalTransitRequest
                   (HdaInternalTransitRequest -> Request HdaInternalTransitRequest)
-> HdaInternalTransitRequest -> Request HdaInternalTransitRequest
forall a b. (a -> b) -> a -> b
$ StateTransit -> HdaInternalTransitRequest
HdaInternalTransitRequest StateTransit
DebugRun_Contaminated

    handleReRun Bool
False = do
      WrapRequest -> AppContext ()
addRequestHP (WrapRequest -> AppContext ()) -> WrapRequest -> AppContext ()
forall a b. (a -> b) -> a -> b
$ Request HdaInternalTerminateRequest -> WrapRequest
forall a. Request a -> WrapRequest
WrapRequest
                   (Request HdaInternalTerminateRequest -> WrapRequest)
-> Request HdaInternalTerminateRequest -> WrapRequest
forall a b. (a -> b) -> a -> b
$ HdaInternalTerminateRequest -> Request HdaInternalTerminateRequest
InternalTerminateRequest
                   (HdaInternalTerminateRequest
 -> Request HdaInternalTerminateRequest)
-> HdaInternalTerminateRequest
-> Request HdaInternalTerminateRequest
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 {
                DAP.seqStoppedEvent = resSeq
              , DAP.bodyStoppedEvent = body
              }

      Response -> AppContext ()
addResponse (Response -> AppContext ()) -> Response -> AppContext ()
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 -> AppContext Handle
isOpenHdl Handle
hdl
             AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isReadableHdl
             AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isNotEofHdl
             AppContext Handle
-> (Handle -> 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
>>= Handle -> AppContext ErrMsg
go

  where
    go :: Handle -> AppContext ErrMsg
go Handle
hdl = IO ErrMsg -> AppContext ErrMsg
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE (IO ErrMsg -> AppContext ErrMsg) -> IO ErrMsg -> AppContext ErrMsg
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 -> AppContext Handle
isOpenHdl Handle
hdl
           AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isReadableHdl
           AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isNotEofHdl
           AppContext Handle
-> (Handle -> StateT AppStores (ExceptT ErrMsg IO) Char)
-> StateT AppStores (ExceptT ErrMsg IO) Char
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
>>= Handle -> StateT AppStores (ExceptT ErrMsg IO) Char
go
           StateT AppStores (ExceptT ErrMsg IO) Char
-> (Char -> 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
>>= Char -> AppContext ErrMsg
forall {m :: * -> *} {a}. Monad m => a -> m [a]
toString
           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
>>= ErrMsg -> AppContext ErrMsg
isNotEmpty

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

    toString :: a -> m [a]
toString a
c = [a] -> m [a]
forall a. a -> m a
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 -> AppContext Handle
isOpenHdl Handle
hdl
               AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isReadableHdl
               AppContext Handle
-> (Handle -> AppContext Handle) -> AppContext Handle
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
>>= Handle -> AppContext Handle
isNotEofHdl
               AppContext Handle
-> (Handle -> AppContext ByteString) -> AppContext ByteString
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
>>= Handle -> AppContext ByteString
go
               AppContext ByteString
-> (ByteString -> AppContext ByteString) -> AppContext ByteString
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
>>= ByteString -> AppContext ByteString
isNotEmptyL

  where
    go :: Handle -> AppContext ByteString
go Handle
hdl = IO ByteString -> AppContext ByteString
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE (IO ByteString -> AppContext ByteString)
-> IO ByteString -> AppContext ByteString
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 -> AppContext Handle
isOpenHdl Handle
rHdl = IO Bool -> StateT AppStores (ExceptT ErrMsg IO) Bool
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE (Handle -> IO Bool
S.hIsOpen Handle
rHdl) StateT AppStores (ExceptT ErrMsg IO) Bool
-> (Bool -> AppContext Handle) -> AppContext Handle
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  -> Handle -> AppContext Handle
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
rHdl
  Bool
False -> ErrMsg -> AppContext Handle
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"invalid HANDLE. not opened."


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


-- |
--
isNotEofHdl :: S.Handle -> AppContext S.Handle
isNotEofHdl :: Handle -> AppContext Handle
isNotEofHdl Handle
rHdl = IO Bool -> StateT AppStores (ExceptT ErrMsg IO) Bool
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE (Handle -> IO Bool
S.hIsEOF Handle
rHdl) StateT AppStores (ExceptT ErrMsg IO) Bool
-> (Bool -> AppContext Handle) -> AppContext Handle
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
False -> Handle -> AppContext Handle
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
rHdl
  Bool
True  -> ErrMsg -> AppContext Handle
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
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
  | ErrMsg -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ErrMsg
b = ErrMsg -> AppContext ErrMsg
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"empty input."
  | Bool
otherwise = ErrMsg -> AppContext ErrMsg
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
BSL.empty = ErrMsg -> AppContext ByteString
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrMsg
"empty input."
  | Bool
otherwise = ByteString -> AppContext ByteString
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b


-- |
--
addEvent :: Event -> AppContext ()
addEvent :: Event -> AppContext ()
addEvent Event
evt = do
  MVar [Event]
mvar <- Getting (MVar [Event]) AppStores (MVar [Event])
-> AppStores -> MVar [Event]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar [Event]) AppStores (MVar [Event])
Lens' AppStores (MVar [Event])
eventStoreAppStores (AppStores -> MVar [Event])
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar [Event])
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
  [Event]
evts <- IO [Event] -> StateT AppStores (ExceptT ErrMsg IO) [Event]
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Event] -> StateT AppStores (ExceptT ErrMsg IO) [Event])
-> IO [Event] -> StateT AppStores (ExceptT ErrMsg IO) [Event]
forall a b. (a -> b) -> a -> b
$ MVar [Event] -> IO [Event]
forall a. MVar a -> IO a
takeMVar MVar [Event]
mvar
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ MVar [Event] -> [Event] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [Event]
mvar ([Event]
evts[Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++[Event
evt])


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE :: forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE IO a
f = IO (Either ErrMsg a)
-> StateT AppStores (ExceptT ErrMsg IO) (Either ErrMsg a)
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either ErrMsg a)
forall b. IO b -> IO (Either ErrMsg b)
go IO a
f) StateT AppStores (ExceptT ErrMsg IO) (Either ErrMsg a)
-> (Either ErrMsg a -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
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 a -> StateT AppStores (ExceptT ErrMsg IO) a
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 = IO (Either ErrMsg b)
-> (SomeException -> IO (Either ErrMsg b)) -> IO (Either ErrMsg b)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
E.catchAny (b -> Either ErrMsg b
forall a b. b -> Either a b
Right (b -> Either ErrMsg b) -> IO b -> IO (Either ErrMsg b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b
f) SomeException -> IO (Either ErrMsg b)
forall a. SomeException -> IO (Either ErrMsg a)
errHdl

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


-- |
--
rstrip :: String -> String
rstrip :: ErrMsg -> ErrMsg
rstrip = Text -> ErrMsg
T.unpack (Text -> ErrMsg) -> (ErrMsg -> Text) -> ErrMsg -> ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.stripEnd (Text -> Text) -> (ErrMsg -> Text) -> ErrMsg -> Text
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 (Text -> ErrMsg) -> (ErrMsg -> Text) -> ErrMsg -> ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (ErrMsg -> Text) -> ErrMsg -> Text
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 (Text -> ErrMsg) -> Text -> ErrMsg
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
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 = (Text -> ErrMsg) -> [Text] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ErrMsg
T.unpack ([Text] -> [ErrMsg]) -> [Text] -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
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 (Text -> ErrMsg) -> Text -> ErrMsg
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate (ErrMsg -> Text
T.pack ErrMsg
a) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> Text) -> [ErrMsg] -> [Text]
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 <- Getting (Maybe ErrMsg) AppStores (Maybe ErrMsg)
-> AppStores -> Maybe ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe ErrMsg) AppStores (Maybe ErrMsg)
Lens' AppStores (Maybe ErrMsg)
stdioLogFileAppStores (AppStores -> Maybe ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (Maybe 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
  Maybe ErrMsg -> AppContext ()
go Maybe ErrMsg
logFile

  where
    go :: Maybe FilePath -> AppContext ()
    go :: Maybe ErrMsg -> AppContext ()
go Maybe ErrMsg
Nothing  = () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (Just ErrMsg
f) = IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
liftIOE (IO () -> AppContext ()) -> IO () -> AppContext ()
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 (ByteString -> AppContext ()) -> ByteString -> AppContext ()
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 (ByteString -> AppContext ()) -> ByteString -> AppContext ()
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"