diff --git a/delta.cabal b/delta.cabal --- a/delta.cabal +++ b/delta.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.0 +version: 0.2.1.0 -- A short (one-line) description of the package. synopsis: A library for detecting file changes @@ -67,16 +67,17 @@ , System.Delta.Poll , System.Delta.Callback , System.Delta.Class + , System.Delta.FRPUtils , System.Delta - if os(darwin) + if (os(darwin) && flag(build_fs_events)) exposed-modules: System.Delta.FSEvents -- Modules included in this library but not exported. - -- other-modules: + -- other-modules: -- LANGUAGE extensions used by modules in this package. - -- other-extensions: + -- other-extensions: -- Other library packages from which modules are imported. build-depends: base >=4.6 && <4.9 @@ -85,7 +86,8 @@ , filepath >= 1.3 , time >= 1.5 , sodium >= 0.11 - if os(darwin) + + if (os(darwin) && flag(build_fs_events)) build-depends: hfsevents >= 0.1.5 -- Directories containing source files. @@ -104,3 +106,20 @@ main-is: Main.hs default-language: Haskell2010 + +executable delta-run + + build-depends: base >= 4.6 && < 4.9 + , delta + , optparse-applicative >= 0.10 + , directory >= 1.2 + , process >= 1.2 + , sodium >= 0.11 + + hs-source-dirs: src/delta-run + + main-is: Main.hs + + default-language: Haskell2010 + + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/System/Delta.hs b/src/System/Delta.hs --- a/src/System/Delta.hs +++ b/src/System/Delta.hs @@ -74,7 +74,7 @@ #if defined(__APPLE__) createFSEventsWatcher path #else - createPollWatcher 10 path + createPollWatcher 5 path #endif -- | Build a file watcher that allows to register callbacks diff --git a/src/System/Delta/Callback.hs b/src/System/Delta/Callback.hs --- a/src/System/Delta/Callback.hs +++ b/src/System/Delta/Callback.hs @@ -16,6 +16,9 @@ -- * Closing the watcher , closeCallbackWatcher + + -- * Helper functions + , callbackOnEvent )where import FRP.Sodium diff --git a/src/System/Delta/FRPUtils.hs b/src/System/Delta/FRPUtils.hs new file mode 100644 --- /dev/null +++ b/src/System/Delta/FRPUtils.hs @@ -0,0 +1,21 @@ +module System.Delta.FRPUtils where + +import Control.Concurrent +import Control.Monad + +import FRP.Sodium + +data Ticker a = Ticker{ tickerInterval :: Int + , tickerEvent :: Event a + , tickerTerminate :: IO () + } + +periodical :: Int -- ^ Milliseconds + -> a -- ^ Item that is sent periodically + -> IO (Ticker a) +periodical ms v = do + (e,push) <- sync $ newEvent + tId <- forkIO . forever $ do + threadDelay $ 1000 * ms + sync $ push v + return $ Ticker ms e (killThread tId) diff --git a/src/System/Delta/Poll.hs b/src/System/Delta/Poll.hs --- a/src/System/Delta/Poll.hs +++ b/src/System/Delta/Poll.hs @@ -33,7 +33,9 @@ -- | Recursively traverse a folder, follow symbolic links but don't -- visit a file twice. -recursiveDescent path = recursiveDescent' M.empty path +recursiveDescent path = + M.filterWithKey (\_ -> not . fileInfoIsDir) <$> -- files only + recursiveDescent' M.empty path -- | Recursively traverse a folder, follows symbolic links, -- doesn't loop however. @@ -95,6 +97,6 @@ threadDelay $ secs * 1000 * 1000 curr <- recursiveDescent path sync $ mapM_ (pushChanged) (fileInfoPath <$> diffChangedFiles last curr) - sync $ mapM_ (pushNew ) (fileInfoPath <$> diffNewFiles last curr) + sync $ mapM_ (pushNew ) (fileInfoPath <$> diffNewFiles last curr ) sync $ mapM_ (pushDeleted) (fileInfoPath <$> diffDeletedFiles last curr) go curr diff --git a/src/delta-run/Main.hs b/src/delta-run/Main.hs new file mode 100644 --- /dev/null +++ b/src/delta-run/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE RecursiveDo #-} +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import FRP.Sodium hiding (value) +import FRP.Sodium.IO +import Options.Applicative + +import System.Exit +import System.Delta +import System.Delta.FRPUtils +import System.Directory +import System.IO +import System.Process + +data Input = Input { inputSeconds :: Int + , inputDir :: FilePath + , inputCommand :: String + } + deriving Show +main = do + input <- execParser opts + inputDirExists <- doesDirectoryExist $ inputDir input + + when (not inputDirExists) + (do + hPutStrLn stderr $ inputDir input ++ " doesn't exist" + exitFailure + ) + + bracket (deltaDir $ inputDir input) + cleanUpAndClose -- Will run after Ctrl-C + (\watcher -> do + + let mergedEvent = (newFiles watcher) `merge` + (deletedFiles watcher) `merge` + (changedFiles watcher) + + ticker <- periodical (1000 * (inputSeconds input)) () + + runE <- sync $ + mkRunEvent mergedEvent (tickerEvent ticker) (runCmd input) + + sync $ listen runE (\_ -> runCmd input) + + threadDelay $ 15 * 1000 * 1000 + ) + where + opts = info (helper <*> optsP) (fullDesc) + optsP = Input + <$> option auto ( long "interval" + <> short 'i' + <> metavar "INTERVAL" + <> help "Run at most every n seconds" + <> value 1 + ) + <*> argument str ( metavar "FILE" + <> help "The directory that is watched" + ) + <*> argument str ( metavar "CMD" + <> help "The command to run" + ) + runCmd input = do + (_,_,_,procHandle) <- + createProcess $ (shell $ inputCommand input){ std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + waitForProcess procHandle + return () + + +mkRunEvent :: Event FilePath -- ^ Changed / Deleted / New file event + -> Event () -- ^ The periodical event + -> IO () -- ^ Execute the input command + -> Reactive (Event (IO ())) +mkRunEvent change ticker run = do + rec + enabled <- hold True $ (const False <$> fire) `merge` (const True <$> ticker) + fireDue <- hold False $ (const True <$> change) `merge` (const False <$> fire) + let firable = (&&) <$> enabled <*> fireDue + + -- Only when we have become firable after not being firable + fire <- filterE (id) <$> (collectE (\c -> \p -> ((c /= p) && c,c)) + True + (updates firable) + ) + + return (const run <$> fire) +