{-# 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.
(HasCallStack, 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 a. a -> IO a
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
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
                -- , W.run  appData    -- file watch
                ]

      -- 
      -- suspend file watch.
      -- because on vbox CentOS Stream release 9, throw error.
      --   Error: couldn't start native file manager: fdType: unsupported operation (unknown file type)
      --
      -- https://github.com/haskell-fswatch/hfsnotify/blob/master/src/System/FSNotify.hs#L167C1-L178C7
      --   case confWatchMode conf of
      --     WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan
      -- #ifndef OS_BSD
      --     WatchModeOS -> liftIO (initSession ()) >>= createManager
      -- #endif
      -- 
      --   where
      -- #ifndef OS_BSD
      --     createManager :: Either Text NativeManager -> IO WatchManager
      --     createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan
      --     createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err
      -- #endif
      -- 
      -- https://github.com/haskell-fswatch/hfsnotify/blob/master/src/System/FSNotify/Linux.hs#L94C1-L97C45
      -- instance FileListener INotifyListener () where
      --   initSession _ = E.handle (\(e :: IOException) -> return $ Left $ fromString $ show e) $ do
      --     inotify <- INo.initINotify
      --     return $ Right $ INotifyListener inotify
      -- 
      -- https://hackage.haskell.org/package/hinotify-0.4.1/docs/src/System.INotify.html#initINotify
      -- initINotify :: IO INotify
      -- initINotify = do
      --     throwErrnoIfMinus1 "initINotify" c_inotify_init
      --     (fd,fd_type) <- FD.mkFD fdint ReadMode (Just (Stream,0,0))
      -- 




      [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a b. IO a -> (a -> IO b) -> IO b
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