{-# 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 = 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 {
        -- 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
argDatforall s a. s -> Getting a s a -> a
^.Lens' ArgData (Maybe String)
stdioLogFileArgData

        -- Read/Write from Application
        , _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

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