From 171b455a3799351a2509b0bdf62952d102a3ff50 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 25 Oct 2024 05:14:38 -0700 Subject: [PATCH] Test improvements --- fsnotify.cabal | 1 + package.yaml | 1 + test/FSNotify/Test/EventTests.hs | 20 +++++++++++--------- test/FSNotify/Test/Util.hs | 27 ++++++++++++++++++++++++--- 4 files changed, 37 insertions(+), 12 deletions(-) diff --git a/fsnotify.cabal b/fsnotify.cabal index 32b36c9..57ff1fb 100644 --- a/fsnotify.cabal +++ b/fsnotify.cabal @@ -92,6 +92,7 @@ test-suite tests , exceptions , filepath , fsnotify + , monad-logger , random , retry , safe-exceptions diff --git a/package.yaml b/package.yaml index bdabbe1..039d953 100644 --- a/package.yaml +++ b/package.yaml @@ -89,6 +89,7 @@ tests: - exceptions - filepath - fsnotify + - monad-logger - random - retry - safe-exceptions diff --git a/test/FSNotify/Test/EventTests.hs b/test/FSNotify/Test/EventTests.hs index cbb3789..29090ad 100644 --- a/test/FSNotify/Test/EventTests.hs +++ b/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 diff --git a/test/FSNotify/Test/Util.hs b/test/FSNotify/Test/Util.hs index 15fa91c..64f38c0 100644 --- a/test/FSNotify/Test/Util.hs +++ b/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,7 +149,7 @@ 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 @@ -143,15 +157,22 @@ introduceTestFolder timeInterval threadingMode poll recursive nested = introduce } 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 ()