{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Haskell.Debug.Adapter.Control (
ArgData(..)
, run
) where
import System.IO
import qualified System.Log.Logger as L
import qualified Control.Exception.Safe as E
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Data.Version (showVersion)
import Paths_haskell_debug_adapter (version)
import Control.Lens
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant
import qualified Haskell.Debug.Adapter.Application as A
import qualified Haskell.Debug.Adapter.Request as RQ
import qualified Haskell.Debug.Adapter.Response as RP
import qualified Haskell.Debug.Adapter.Watch as W
run :: ArgData
-> Handle
-> Handle
-> IO ()
run :: ArgData -> Handle -> Handle -> IO ()
run ArgData
argDat Handle
inHdl Handle
outHdl = forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO AppStores
initialize forall {p}. p -> IO ()
finalize AppStores -> IO ()
go
where
initialize :: IO AppStores
initialize = do
String -> String -> IO ()
L.debugM String
_LOG_NAME forall a b. (a -> b) -> a -> b
$ String
"initialize called."
Handle -> BufferMode -> IO ()
hSetBuffering Handle
inHdl BufferMode
NoBuffering
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
inHdl TextEncoding
utf8
Handle -> BufferMode -> IO ()
hSetBuffering Handle
outHdl BufferMode
NoBuffering
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
outHdl TextEncoding
utf8
MVar [WrapRequest]
reqStore <- forall a. a -> IO (MVar a)
newMVar []
MVar [Response]
resStore <- forall a. a -> IO (MVar a)
newMVar []
MVar [Event]
evtStore <- forall a. a -> IO (MVar a)
newMVar []
MVar String
wsStore <- forall a. a -> IO (MVar a)
newMVar String
""
MVar Priority
logPRStore <- forall a. a -> IO (MVar a)
newMVar Priority
L.WARNING
MVar GHCiProc
procStore <- forall a. IO (MVar a)
newEmptyMVar
MVar Version
verStore <- forall a. IO (MVar a)
newEmptyMVar
forall (m :: * -> *) a. Monad m => a -> m a
return AppStores {
_appNameAppStores :: String
_appNameAppStores = String
"haskell-debug-adapter"
, _appVerAppStores :: String
_appVerAppStores = Version -> String
showVersion Version
version
, _inHandleAppStores :: Handle
_inHandleAppStores = Handle
inHdl
, _outHandleAppStores :: Handle
_outHandleAppStores = Handle
outHdl
, _asyncsAppStores :: [Async ()]
_asyncsAppStores = []
, _stdioLogFileAppStores :: Maybe String
_stdioLogFileAppStores = ArgData
argDatforall s a. s -> Getting a s a -> a
^.Lens' ArgData (Maybe String)
stdioLogFileArgData
, _appStateWAppStores :: WrapAppState
_appStateWAppStores = forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState InitStateData
InitState
, _resSeqAppStores :: Int
_resSeqAppStores = Int
0
, _startupAppStores :: String
_startupAppStores = String
""
, _startupFuncAppStores :: String
_startupFuncAppStores = String
""
, _startupArgsAppStores :: String
_startupArgsAppStores = String
""
, _stopOnEntryAppStores :: Bool
_stopOnEntryAppStores = Bool
False
, _ghciPmptAppStores :: String
_ghciPmptAppStores = String
_GHCI_PROMPT_HDA
, _mainArgsAppStores :: String
_mainArgsAppStores = String
""
, _launchReqSeqAppStores :: Int
_launchReqSeqAppStores = -Int
1
, _debugReRunableAppStores :: Bool
_debugReRunableAppStores = Bool
False
, _reqStoreAppStores :: MVar [WrapRequest]
_reqStoreAppStores = MVar [WrapRequest]
reqStore
, _resStoreAppStores :: MVar [Response]
_resStoreAppStores = MVar [Response]
resStore
, _eventStoreAppStores :: MVar [Event]
_eventStoreAppStores = MVar [Event]
evtStore
, _workspaceAppStores :: MVar String
_workspaceAppStores = MVar String
wsStore
, _logPriorityAppStores :: MVar Priority
_logPriorityAppStores = MVar Priority
logPRStore
, _ghciProcAppStores :: MVar GHCiProc
_ghciProcAppStores = MVar GHCiProc
procStore
, _ghciVerAppStores :: MVar Version
_ghciVerAppStores = MVar Version
verStore
}
finalize :: p -> IO ()
finalize p
_ = do
String -> String -> IO ()
L.debugM String
_LOG_NAME forall a b. (a -> b) -> a -> b
$ String
"finalize called."
IO ()
L.removeAllHandlers
go :: AppStores -> IO ()
go AppStores
appData = do
String -> String -> IO ()
L.debugM String
_LOG_NAME forall a b. (a -> b) -> a -> b
$ String
"start thread manager."
let ths :: [IO ()]
ths = [
AppStores -> IO ()
RQ.run AppStores
appData
, AppStores -> IO ()
A.run AppStores
appData
, AppStores -> IO ()
RP.run AppStores
appData
, AppStores -> IO ()
W.run AppStores
appData
]
[Async ()]
as <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. IO a -> IO (Async a)
async [IO ()]
ths
forall a. [Async a] -> IO (Async a, Either SomeException a)
waitAnyCatchCancel [Async ()]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Async ()
_, Right ()
_) -> String -> String -> IO ()
L.infoM String
_LOG_NAME forall a b. (a -> b) -> a -> b
$ String
"some threads stopped. exit."
(Async ()
_, Left SomeException
e) -> String -> String -> IO ()
L.criticalM String
_LOG_NAME forall a b. (a -> b) -> a -> b
$ String
"some threads stopped. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e