Simplify some file watching code (#14)

* Fix 7.6.3 build

* Simplify tree-watching code

.gitignore

@@ -9,3 +9,4 @@ dist/**
 cabal.sandbox.config
 .stack-work/
 .sosrc*
+codex.tags

app/Main.hs

@@ -3,8 +3,9 @@ module Main where
 import Sos
 import Sos.Utils
 
+import qualified System.FSNotify.Streaming as FSNotify
+
 import Control.Concurrent.Async
-import Control.Concurrent.Chan
 import Control.Monad
 import Control.Monad.Except
 import Data.ByteString        (ByteString)
@@ -20,7 +21,6 @@ import System.IO
 
 import qualified Data.Foldable     as Foldable
 import qualified Streaming.Prelude as S
-import qualified System.FSNotify   as FSNotify
 
 
 version :: String
@@ -97,69 +97,67 @@ main' Options{..} = do
 
   putStrLn "Hit Ctrl+C to quit."
 
-  FSNotify.withManager $ \manager -> do
-    job_queue <- newJobQueue
-
-    let enqueue_thread :: IO a
-        enqueue_thread =
-          runSos (sosEnqueueJobs rules (eventStream manager target) job_queue)
-
-        -- Run jobs forever, only stopping to prompt whether or not to run
-        -- enqueued jobs when a job fails. This way, the failing job's output
-        -- will not be lost by subsequent jobs' outputs without the user's
-        -- consent.
-        dequeue_thread :: IO a
-        dequeue_thread = forever $ do
-          dequeueJob job_queue >>= \case
-            JobSuccess -> pure ()
-            JobFailure -> do
-              jobQueueLength job_queue >>= \case
-                0 -> pure ()
-                n -> do
-                  putStrLn (yellow (show n ++ " job(s) still pending."))
-
-                  hSetBuffering stdin NoBuffering
-                  continue <- fix (\prompt -> do
-                    putStr (yellow "Press 'c' to continue, 'p' to print, or 'a' to abort: ")
-                    hFlush stdout
-                    (getChar <* putStrLn "") >>= \case
-                      'c' -> pure True
-                      'a' -> pure False
-                      'p' -> do
-                        jobs <- jobQueueJobs job_queue
-                        Foldable.forM_ (jobCommands <$> jobs) $
-                          (\(c:|cs) -> do
-                            putStrLn ("- " ++ c)
-                            mapM_ (putStrLn . ("  " ++)) cs)
-                        prompt
-                      _ -> prompt)
-                  hSetBuffering stdin LineBuffering
-
-                  unless continue $ do
-                    n' <- jobQueueLength job_queue
-                    clearJobQueue job_queue
-                    putStrLn (red ("Aborted " ++ show n' ++ " job(s)."))
-
-    race_ enqueue_thread dequeue_thread
-
--- | Make a stream of 'FileEvent's from a watched directory.
-eventStream
-  :: MonadIO m
-  => FSNotify.WatchManager
-  -> FilePath
-  -> Stream (Of FileEvent) m a
-eventStream manager target = do
-  cwd  <- liftIO getCurrentDirectory
-  chan <- liftIO newChan
-  _    <- liftIO (FSNotify.watchTreeChan manager target (const True) chan)
-  forever $
-    liftIO (readChan chan) >>= \case
-      FSNotify.Added    path _ -> S.yield (FileAdded    (go cwd path))
-      FSNotify.Modified path _ -> S.yield (FileModified (go cwd path))
-      FSNotify.Removed  _    _ -> pure ()
-   where
-    go :: FilePath -> FilePath -> ByteString
-    go cwd path = packBS (makeRelative cwd path)
+  job_queue <- newJobQueue
+
+  let enqueue_thread :: IO a
+      enqueue_thread =
+        runSos (sosEnqueueJobs rules (watchTree target) job_queue)
+
+      -- Run jobs forever, only stopping to prompt whether or not to run
+      -- enqueued jobs when a job fails. This way, the failing job's output
+      -- will not be lost by subsequent jobs' outputs without the user's
+      -- consent.
+      dequeue_thread :: IO a
+      dequeue_thread = forever $ do
+        dequeueJob job_queue >>= \case
+          JobSuccess -> pure ()
+          JobFailure -> do
+            jobQueueLength job_queue >>= \case
+              0 -> pure ()
+              n -> do
+                putStrLn (yellow (show n ++ " job(s) still pending."))
+
+                hSetBuffering stdin NoBuffering
+                continue <- fix (\prompt -> do
+                  putStr (yellow "Press 'c' to continue, 'p' to print, or 'a' to abort: ")
+                  hFlush stdout
+                  (getChar <* putStrLn "") >>= \case
+                    'c' -> pure True
+                    'a' -> pure False
+                    'p' -> do
+                      jobs <- jobQueueJobs job_queue
+                      Foldable.forM_ (jobCommands <$> jobs) $
+                        (\(c:|cs) -> do
+                          putStrLn ("- " ++ c)
+                          mapM_ (putStrLn . ("  " ++)) cs)
+                      prompt
+                    _ -> prompt)
+                hSetBuffering stdin LineBuffering
+
+                unless continue $ do
+                  n' <- jobQueueLength job_queue
+                  clearJobQueue job_queue
+                  putStrLn (red ("Aborted " ++ show n' ++ " job(s)."))
+
+  race_ enqueue_thread dequeue_thread
+
+watchTree
+  :: forall m a.
+     MonadResource m
+  => FilePath -> Stream (Of FileEvent) m a
+watchTree target = do
+  cwd <- liftIO getCurrentDirectory
+
+  let stream :: Stream (Of FSNotify.Event) m a
+      stream = FSNotify.watchTree FSNotify.defaultConfig target (const True)
+
+  S.for stream (\case
+    FSNotify.Added    path _ -> S.yield (FileAdded    (go cwd path))
+    FSNotify.Modified path _ -> S.yield (FileModified (go cwd path))
+    FSNotify.Removed  _    _ -> pure ())
+ where
+  go :: FilePath -> FilePath -> ByteString
+  go cwd path = packBS (makeRelative cwd path)
 
 --------------------------------------------------------------------------------
 

package.yaml

@@ -34,8 +34,10 @@ dependencies:
   - async      >= 2.0
   - base       >= 4.0 && < 5.0
   - bytestring >= 0.10
+  - fsnotify   >= 0.2
   - mtl        >= 2.2
   - regex-tdfa >= 1.2
+  - resourcet  >= 1.0
   - semigroups >= 0.16
   - stm        >= 2.4
   - streaming  >= 0.1.0 && < 0.1.5
@@ -57,7 +59,6 @@ executables:
     dependencies:
       - steeloverseer
       - directory >= 1.2
-      - fsnotify >= 0.2
       - filepath >= 1.3
       - optparse-applicative >= 0.11
     when:

src/Sos.hs

@@ -19,20 +19,21 @@ import Sos.Template
 
 import Control.Applicative
 import Control.Monad.Except
-import Data.List.NonEmpty   (NonEmpty(..))
+import Control.Monad.Trans.Resource
+import Data.List.NonEmpty           (NonEmpty(..))
 import Streaming
 import System.Exit
-import Text.Regex.TDFA      (match)
+import Text.Regex.TDFA              (match)
 
 import qualified Streaming.Prelude as S
 
 
-type Sos a = ExceptT SosException IO a
+type Sos a = ResourceT (ExceptT SosException IO) a
 
 -- | Run an 'Sos' action in IO, exiting if any 'SosException's are thrown.
 runSos :: Sos a -> IO a
 runSos act =
-  runExceptT act >>= \case
+  runExceptT (runResourceT act) >>= \case
     Left err -> do
       print err
       exitFailure
@@ -42,7 +43,7 @@ runSos act =
 -- rules to each emitted file event from the given stream. This function
 -- returns when the stream is exhausted.
 sosEnqueueJobs
-  :: (Applicative m, MonadError SosException m, MonadIO m)
+  :: (Applicative m, MonadError SosException m, MonadResource m)
   => [Rule]
   -> Stream (Of FileEvent) m a
   -> JobQueue

src/System/FSNotify/Streaming.hs

@@ -0,0 +1,26 @@
+-- | A streaming wrapper around System.FSNotify.
+
+module System.FSNotify.Streaming
+  ( System.FSNotify.Streaming.watchTree
+    -- * Re-exports
+  , Event(..)
+  , WatchManager
+  , defaultConfig
+  ) where
+
+import Control.Concurrent.Chan
+import Control.Monad
+import Control.Monad.Trans.Resource
+import Streaming
+import Streaming.Prelude (yield)
+import System.FSNotify
+
+watchTree
+  :: MonadResource m
+  => WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) m a
+watchTree config path predicate = do
+  chan         <- liftIO newChan
+  (_, manager) <- allocate (startManagerConf config) stopManager
+  _            <- allocate (watchTreeChan manager path predicate chan) id
+
+  forever (liftIO (readChan chan) >>= yield)

steeloverseer.cabal

@@ -35,13 +35,16 @@ library
           Sos.Rule
           Sos.Template
           Sos.Utils
+          System.FSNotify.Streaming
     default-language: Haskell2010
     build-depends:
           async      >= 2.0
         , base       >= 4.0 && < 5.0
         , bytestring >= 0.10
+        , fsnotify   >= 0.2
         , mtl        >= 2.2
         , regex-tdfa >= 1.2
+        , resourcet  >= 1.0
         , semigroups >= 0.16
         , stm        >= 2.4
         , streaming  >= 0.1.0 && < 0.1.5
@@ -62,16 +65,17 @@ executable sos
           async      >= 2.0
         , base       >= 4.0 && < 5.0
         , bytestring >= 0.10
+        , fsnotify   >= 0.2
         , mtl        >= 2.2
         , regex-tdfa >= 1.2
+        , resourcet  >= 1.0
         , semigroups >= 0.16
         , stm        >= 2.4
         , streaming  >= 0.1.0 && < 0.1.5
         , text       >= 1.2
         , yaml       >= 0.8
         , steeloverseer
         , directory >= 1.2
-        , fsnotify >= 0.2
         , filepath >= 1.3
         , optparse-applicative >= 0.11
     if os(darwin)
@@ -94,8 +98,10 @@ test-suite spec
           async      >= 2.0
         , base       >= 4.0 && < 5.0
         , bytestring >= 0.10
+        , fsnotify   >= 0.2
         , mtl        >= 2.2
         , regex-tdfa >= 1.2
+        , resourcet  >= 1.0
         , semigroups >= 0.16
         , stm        >= 2.4
         , streaming  >= 0.1.0 && < 0.1.5

test/Sos/TemplateSpec.hs

@@ -2,7 +2,6 @@ module Sos.TemplateSpec where
 
 import Sos.Template
 
-import Data.Either (isLeft)
 import Test.Hspec
 
 spec :: Spec
@@ -29,3 +28,7 @@ spec = do
     it "errors when there are not enough capture groups" $ do
       instantiateTemplate []    [Left 0] `shouldSatisfy` isLeft
       instantiateTemplate ["a"] [Left 1] `shouldSatisfy` isLeft
+
+isLeft :: Either a b -> Bool
+isLeft (Left _) = True
+isLeft _ = False