{-# LANGUAGE LambdaCase #-}

module Haskell.Debug.Adapter.Watch where

import Control.Monad.IO.Class
import qualified System.FSNotify as S
import Control.Lens
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
import Control.Monad.State.Lazy
import qualified System.Log.Logger as L
import Control.Monad.Except
import qualified Data.List as L

import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Utility
import Haskell.Debug.Adapter.Constant


-- |
--
run :: AppStores -> IO ()
run :: AppStores -> IO ()
run AppStores
appData = do
  String -> String -> IO ()
L.debugM String
_LOG_WATCH String
"start watch app"
  Either String ((), AppStores)
_ <- AppStores -> AppContext () -> IO (Either String ((), AppStores))
forall a.
AppStores -> AppContext a -> IO (Either String (a, AppStores))
runApp AppStores
appData AppContext ()
app
  String -> String -> IO ()
L.debugM String
_LOG_WATCH String
"end watch app"


-- |
--
app :: AppContext ()
app :: AppContext ()
app = (AppContext () -> (String -> AppContext ()) -> AppContext ())
-> (String -> AppContext ()) -> AppContext () -> AppContext ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext () -> (String -> AppContext ()) -> AppContext ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError String -> AppContext ()
errHdl (AppContext () -> AppContext ()) -> AppContext () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ do
  IO () -> AppContext ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.infoM String
_LOG_WATCH String
"wait getting workspace path."
  String
ws <- AppContext String
getWS
  IO () -> AppContext ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.infoM String
_LOG_WATCH (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"start watching " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ws

  MVar [WrapRequest]
reqStore <- 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 String IO) AppStores
-> StateT AppStores (ExceptT String IO) (MVar [WrapRequest])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT String IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  let conf :: WatchConfig
conf = WatchConfig
S.defaultConfig { confDebounce :: Debounce
S.confDebounce  = NominalDiffTime -> Debounce
S.Debounce NominalDiffTime
1} 
  IO () -> AppContext ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ WatchConfig -> (WatchManager -> IO ()) -> IO ()
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
S.withManagerConf WatchConfig
conf ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> MVar [WrapRequest] -> WatchManager -> IO ()
forall b. String -> MVar [WrapRequest] -> WatchManager -> IO b
goIO String
ws MVar [WrapRequest]
reqStore
  
  where
    -- |
    --
    errHdl :: String -> AppContext ()
errHdl String
msg = do
      String -> String -> AppContext ()
criticalEV String
_LOG_REQUEST String
msg
      Event -> AppContext ()
addEvent Event
CriticalExitEvent

    -- |
    --
    goIO :: String -> MVar [WrapRequest] -> WatchManager -> IO b
goIO String
ws MVar [WrapRequest]
reqStore WatchManager
mgr = do
      WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
S.watchTree WatchManager
mgr String
ws ActionPredicate
hsFilter (MVar [WrapRequest] -> Action
action MVar [WrapRequest]
reqStore)
      IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
_1_SEC

    -- |
    --
    hsFilter :: ActionPredicate
hsFilter Event
ev = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf String
_HS_FILE_EXT (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Event -> String
S.eventPath Event
ev

    -- |
    --
    action :: MVar [WrapRequest] -> Action
action MVar [WrapRequest]
mvar ev :: Event
ev@(S.Added{}) = MVar [WrapRequest] -> Action
sendRequest MVar [WrapRequest]
mvar Event
ev
    action MVar [WrapRequest]
mvar ev :: Event
ev@(S.Modified{}) = MVar [WrapRequest] -> Action
sendRequest MVar [WrapRequest]
mvar Event
ev
    action MVar [WrapRequest]
_ Event
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- |
    --
    sendRequest :: MVar [WrapRequest] -> Action
sendRequest MVar [WrapRequest]
mvar Event
ev = do
      String -> String -> IO ()
L.debugM String
_LOG_WATCH (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"detect. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
ev
      let req :: WrapRequest
req = Request HdaInternalLoadRequest -> WrapRequest
forall a. Request a -> WrapRequest
WrapRequest (Request HdaInternalLoadRequest -> WrapRequest)
-> Request HdaInternalLoadRequest -> WrapRequest
forall a b. (a -> b) -> a -> b
$ HdaInternalLoadRequest -> Request HdaInternalLoadRequest
InternalLoadRequest 
              (HdaInternalLoadRequest -> Request HdaInternalLoadRequest)
-> HdaInternalLoadRequest -> Request HdaInternalLoadRequest
forall a b. (a -> b) -> a -> b
$ String -> HdaInternalLoadRequest
HdaInternalLoadRequest (String -> HdaInternalLoadRequest)
-> String -> HdaInternalLoadRequest
forall a b. (a -> b) -> a -> b
$ Event -> String
S.eventPath Event
ev
      [WrapRequest]
reqs <- MVar [WrapRequest] -> IO [WrapRequest]
forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
mvar
      MVar [WrapRequest] -> [WrapRequest] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
mvar (WrapRequest
req WrapRequest -> [WrapRequest] -> [WrapRequest]
forall a. a -> [a] -> [a]
: [WrapRequest]
reqs)
  

    -- |
    -- 
    getWS :: AppContext FilePath
    getWS :: AppContext String
getWS = do
      MVar String
wsMVar <- Getting (MVar String) AppStores (MVar String)
-> AppStores -> MVar String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar String) AppStores (MVar String)
Lens' AppStores (MVar String)
workspaceAppStores (AppStores -> MVar String)
-> StateT AppStores (ExceptT String IO) AppStores
-> StateT AppStores (ExceptT String IO) (MVar String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT String IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
      String
ws <- IO String -> AppContext String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> AppContext String) -> IO String -> AppContext String
forall a b. (a -> b) -> a -> b
$ MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
wsMVar
      if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ws) then String -> AppContext String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ws
        else do
          IO () -> AppContext ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
_1_SEC
          AppContext String
getWS