{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}

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

import System.FilePath

#if __GLASGOW_HASKELL__ >= 906
import Control.Monad
#endif
-- |
--
run :: AppStores -> IO ()
run :: AppStores -> IO ()
run AppStores
appData = do
  ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_WATCH ErrMsg
"start watch app"
  Either ErrMsg ((), AppStores)
_ <- AppStores -> AppContext () -> IO (Either ErrMsg ((), AppStores))
forall a.
AppStores -> AppContext a -> IO (Either ErrMsg (a, AppStores))
runApp AppStores
appData AppContext ()
app
  ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_WATCH ErrMsg
"end watch app"


-- |
--
app :: AppContext ()
app :: AppContext ()
app = (AppContext () -> (ErrMsg -> AppContext ()) -> AppContext ())
-> (ErrMsg -> AppContext ()) -> AppContext () -> AppContext ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext () -> (ErrMsg -> AppContext ()) -> AppContext ()
forall a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ErrMsg -> AppContext ()
errHdl (AppContext () -> AppContext ()) -> AppContext () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ do
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_WATCH ErrMsg
"wait getting workspace path."
  ErrMsg
ws <- AppContext ErrMsg
getWS
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_WATCH (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"start watching " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
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 ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar [WrapRequest])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  let conf :: WatchConfig
conf = WatchConfig
S.defaultConfig
  IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
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
$ ErrMsg -> MVar [WrapRequest] -> WatchManager -> IO ()
forall {b}. ErrMsg -> MVar [WrapRequest] -> WatchManager -> IO b
goIO ErrMsg
ws MVar [WrapRequest]
reqStore
  
  where
    -- |
    --
    errHdl :: ErrMsg -> AppContext ()
errHdl ErrMsg
msg = do
      ErrMsg -> ErrMsg -> AppContext ()
criticalEV ErrMsg
_LOG_REQUEST ErrMsg
msg
      Event -> AppContext ()
addEvent Event
CriticalExitEvent

    -- |
    --
    goIO :: ErrMsg -> MVar [WrapRequest] -> WatchManager -> IO b
goIO ErrMsg
ws MVar [WrapRequest]
reqStore WatchManager
mgr = do
      WatchManager -> ErrMsg -> ActionPredicate -> Action -> IO (IO ())
S.watchTree WatchManager
mgr ErrMsg
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 = (ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf ErrMsg
_HS_FILE_EXT (Event -> ErrMsg
S.eventPath Event
ev))
               Bool -> Bool -> Bool
&& (Bool -> Bool
not (ErrMsg -> ErrMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf (Char
pathSeparatorChar -> ErrMsg -> ErrMsg
forall a. a -> [a] -> [a]
:ErrMsg
".") (Event -> ErrMsg
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- |
    --
    sendRequest :: MVar [WrapRequest] -> Action
sendRequest MVar [WrapRequest]
mvar Event
ev = do
      ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_WATCH (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"detect. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ Event -> ErrMsg
forall a. Show a => a -> ErrMsg
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
$ ErrMsg -> HdaInternalLoadRequest
HdaInternalLoadRequest (ErrMsg -> HdaInternalLoadRequest)
-> ErrMsg -> HdaInternalLoadRequest
forall a b. (a -> b) -> a -> b
$ Event -> ErrMsg
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 ErrMsg
getWS = do
      MVar ErrMsg
wsMVar <- Getting (MVar ErrMsg) AppStores (MVar ErrMsg)
-> AppStores -> MVar ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar ErrMsg) AppStores (MVar ErrMsg)
Lens' AppStores (MVar ErrMsg)
workspaceAppStores (AppStores -> MVar ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) (MVar ErrMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
      ErrMsg
ws <- IO ErrMsg -> AppContext ErrMsg
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ErrMsg -> AppContext ErrMsg) -> IO ErrMsg -> AppContext ErrMsg
forall a b. (a -> b) -> a -> b
$ MVar ErrMsg -> IO ErrMsg
forall a. MVar a -> IO a
readMVar MVar ErrMsg
wsMVar
      if Bool -> Bool
not (ErrMsg -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ErrMsg
ws) then ErrMsg -> AppContext ErrMsg
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ErrMsg
ws
        else do
          IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
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 ErrMsg
getWS