Test improvements

fsnotify.cabal

@@ -92,6 +92,7 @@ test-suite tests
     , exceptions
     , filepath
     , fsnotify
+    , monad-logger
     , random
     , retry
     , safe-exceptions

package.yaml

@@ -89,6 +89,7 @@ tests:
     - exceptions
     - filepath
     - fsnotify
+    - monad-logger
     - random
     - retry
     - safe-exceptions

test/FSNotify/Test/EventTests.hs

@@ -1,10 +1,12 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Redundant multi-way if" #-}
 
@@ -27,19 +29,19 @@ import UnliftIO.Directory
 eventTests :: (
   MonadUnliftIO m, MonadThrow m
   ) => ThreadingMode -> SpecFree context m ()
-eventTests threadingMode = describe "Tests" $ parallel $ do
+eventTests threadingMode = describe "Tests" $ parallelWithoutDirectory $ do
   let pollOptions = if isBSD then [True] else [False, True]
 
-  forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallel $ do
+  forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallelWithoutDirectory $ do
     let timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)
-    forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallel $
-      forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallel $
+    forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallelWithoutDirectory $
+      forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallelWithoutDirectory $
         eventTests' timeInterval threadingMode poll recursive nested
 
 eventTests' :: (
   MonadUnliftIO m, MonadThrow m
   ) => Int -> ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()
-eventTests' timeInterval threadingMode poll recursive nested = do -- withParallelSemaphore $
+eventTests' timeInterval threadingMode poll recursive nested = do
   let itWithFolder name action = introduceTestFolder timeInterval threadingMode poll recursive nested $ it name action
 
   unless (nested || poll || isMac || isWin) $ itWithFolder "deletes the watched directory" $ do

test/FSNotify/Test/Util.hs

@@ -13,6 +13,7 @@ module FSNotify.Test.Util where
 
 import Control.Exception.Safe (Handler(..))
 import Control.Monad
+import Control.Monad.Logger
 import Control.Retry
 import Data.String.Interpolate
 import System.FSNotify
@@ -109,7 +110,20 @@ introduceTestFolder :: (
   -> Bool
   -> SpecFree (LabelValue "testFolderContext" TestFolderContext :> context) m ()
   -> SpecFree context m ()
-introduceTestFolder timeInterval threadingMode poll recursive nested = introduceWith "Make test folder" testFolderContext $ \action -> do
+introduceTestFolder timeInterval threadingMode poll recursive nested = introduceWith "Make test folder" testFolderContext $ \action ->
+  withTestFolder timeInterval threadingMode poll recursive nested (void . action)
+
+withTestFolder :: (
+  MonadUnliftIO m, MonadLogger m
+  )
+  => Int
+  -> ThreadingMode
+  -> Bool
+  -> Bool
+  -> Bool
+  -> (TestFolderContext -> m a)
+  -> m a
+withTestFolder timeInterval threadingMode poll recursive nested action = do
   withRandomTempDirectory $ \watchedDir' -> do
     info [i|Got temp directory: #{watchedDir'}|]
     let fileName = "testfile"
@@ -135,23 +149,30 @@ introduceTestFolder timeInterval threadingMode poll recursive nested = introduce
       withManagerConf conf $ \mgr -> do
         eventsVar <- newIORef []
         stop <- watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ())))
-        _ <- runInIO $ action $ TestFolderContext {
+        ret <- runInIO $ action $ TestFolderContext {
           watchedDir = watchedDir'
           , filePath = normalise $ baseDir </> fileName
           , getEvents = readIORef eventsVar
           , clearEvents = threadDelay timeInterval >> atomicWriteIORef eventsVar []
           }
 
         stop
+        return ret
 
 
 -- | Use a random identifier so that every test happens in a different folder
 -- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs
-withRandomTempDirectory :: MonadUnliftIO m => (FilePath -> m ()) -> m ()
+withRandomTempDirectory :: MonadUnliftIO m => (FilePath -> m a) -> m a
 withRandomTempDirectory action = do
   randomID <- liftIO $ replicateM 10 $ R.randomRIO ('a', 'z')
   withSystemTempDirectory ("test." <> randomID) action
 
+parallelWithoutDirectory :: SpecFree context m () -> SpecFree context m ()
+parallelWithoutDirectory = parallel' (defaultNodeOptions {
+                                         nodeOptionsCreateFolder = False
+                                         , nodeOptionsVisibilityThreshold = 70
+                                         })
+
 -- withParallelSemaphore :: forall context m. (
 --   MonadUnliftIO m, HasLabel context "parallelSemaphore" QSem
 --   ) => SpecFree context m () -> SpecFree context m ()