{-# 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


-- |
--   Start HDA.
--   Default implementation is using STDIN/STDOUT handle.
--
--   Here is an example for using TCP Socket.
--
-- > import Network.Socket
-- >
-- > sock <- socket AF_INET Stream defaultProtocol
-- > let host = tupleToHostAddress (0, 0, 0, 0)
-- >     port = 9999
-- >     reqQ = 5
-- >
-- > bind sock $ SockAddrInet port host
-- > listen sock reqQ
-- >
-- > (conn, _) <- accept sock
-- > hdl <- socketToHandle conn ReadWriteMode
-- >
-- > run def hdl hdl
-- >
--
--   Port 9999 could be specified in the launch.json with "debugServer" attribute.
--
-- > "debugServer : 9999"
--
run :: ArgData -- ^command line arguments.
    -> Handle  -- ^IN handle. used to get request from the debug adapter client.
    -> Handle  -- ^OUT handle. used to response to the debug adapter client.
    -> IO ()
run :: ArgData -> Handle -> Handle -> IO ()
run ArgData
argDat Handle
inHdl Handle
outHdl = IO AppStores
-> (AppStores -> IO ()) -> (AppStores -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO AppStores
initialize AppStores -> IO ()
forall p. p -> IO ()
finalize AppStores -> IO ()
go

  where
    -- |
    --
    initialize :: IO AppStores
initialize = do
      String -> String -> IO ()
L.debugM String
_LOG_NAME (String -> IO ()) -> String -> IO ()
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 <- [WrapRequest] -> IO (MVar [WrapRequest])
forall a. a -> IO (MVar a)
newMVar []
      MVar [Response]
resStore <- [Response] -> IO (MVar [Response])
forall a. a -> IO (MVar a)
newMVar []
      MVar [Event]
evtStore <- [Event] -> IO (MVar [Event])
forall a. a -> IO (MVar a)
newMVar []
      MVar String
wsStore  <- String -> IO (MVar String)
forall a. a -> IO (MVar a)
newMVar String
""
      MVar Priority
logPRStore <- Priority -> IO (MVar Priority)
forall a. a -> IO (MVar a)
newMVar Priority
L.WARNING
      MVar GHCiProc
procStore  <- IO (MVar GHCiProc)
forall a. IO (MVar a)
newEmptyMVar
      MVar Version
verStore   <- IO (MVar Version)
forall a. IO (MVar a)
newEmptyMVar

      AppStores -> IO AppStores
forall (m :: * -> *) a. Monad m => a -> m a
return AppStores :: String
-> String
-> Handle
-> Handle
-> [Async ()]
-> Maybe String
-> WrapAppState
-> Int
-> String
-> String
-> String
-> Bool
-> String
-> String
-> Int
-> Bool
-> MVar [WrapRequest]
-> MVar [Response]
-> MVar [Event]
-> MVar String
-> MVar Priority
-> MVar GHCiProc
-> MVar Version
-> AppStores
AppStores {
        -- Read Only
          _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
argDatArgData
-> Getting (Maybe String) ArgData (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^.Getting (Maybe String) ArgData (Maybe String)
Lens' ArgData (Maybe String)
stdioLogFileArgData

        -- Read/Write from Application
        , _appStateWAppStores :: WrapAppState
_appStateWAppStores   = AppState InitStateData -> WrapAppState
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

        -- Read/Write ASync
        , _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 (String -> IO ()) -> String -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"start thread manager."

      let ths :: [IO ()]
ths = [
                  AppStores -> IO ()
RQ.run AppStores
appData    -- request handler
                , AppStores -> IO ()
A.run  AppStores
appData    -- main app
                , AppStores -> IO ()
RP.run AppStores
appData    -- response handler
                , AppStores -> IO ()
W.run  AppStores
appData    -- file watch
                ]

      [Async ()]
as <- (IO () -> IO (Async ())) -> [IO ()] -> IO [Async ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async [IO ()]
ths
      [Async ()] -> IO (Async (), Either SomeException ())
forall a. [Async a] -> IO (Async a, Either SomeException a)
waitAnyCatchCancel [Async ()]
as IO (Async (), Either SomeException ())
-> ((Async (), Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Async ()
_, Right ()
_) -> String -> String -> IO ()
L.infoM String
_LOG_NAME (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"some threads stopped. exit."
        (Async ()
_, Left SomeException
e)  -> String -> String -> IO ()
L.criticalM String
_LOG_NAME (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"some threads stopped. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e