{-# 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)
_ <- 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ErrMsg -> AppContext ()
errHdl forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_WATCH forall a b. (a -> b) -> a -> b
$ ErrMsg
"start watching " forall a. [a] -> [a] -> [a]
++ ErrMsg
ws

  MVar [WrapRequest]
reqStore <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  let conf :: WatchConfig
conf = WatchConfig
S.defaultConfig
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
S.withManagerConf WatchConfig
conf forall a b. (a -> b) -> a -> b
$ 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)
      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
_1_SEC

    -- |
    --
    hsFilter :: ActionPredicate
hsFilter Event
ev = (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 (forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf (Char
pathSeparatorforall 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
_ = 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 forall a b. (a -> b) -> a -> b
$ ErrMsg
"detect. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrMsg
show Event
ev
      let req :: WrapRequest
req = forall a. Request a -> WrapRequest
WrapRequest forall a b. (a -> b) -> a -> b
$ HdaInternalLoadRequest -> Request HdaInternalLoadRequest
InternalLoadRequest 
              forall a b. (a -> b) -> a -> b
$ ErrMsg -> HdaInternalLoadRequest
HdaInternalLoadRequest forall a b. (a -> b) -> a -> b
$ Event -> ErrMsg
S.eventPath Event
ev
      [WrapRequest]
reqs <- forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
mvar
      forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
mvar (WrapRequest
req forall a. a -> [a] -> [a]
: [WrapRequest]
reqs)
  

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