Run filesystem event tests without hspec

.github/workflows/haskell.yml

@@ -34,6 +34,7 @@ jobs:
       # default (ncpus) is good, this can be checked from the packcheck
       # output in case it changes.
       CABAL_BUILD_OPTIONS: ${{ matrix.cabal_build_options }}
+      # CABAL_TEST_OPTIONS: -j1
       CABAL_BUILD_TARGETS: ${{ matrix.cabal_build_targets }}
       CABAL_PROJECT: ${{ matrix.cabal_project }}
       CABAL_CHECK_RELAX: y
@@ -47,7 +48,7 @@ jobs:
       # packcheck location and revision
       PACKCHECK: "./packcheck.sh"
       PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck"
-      PACKCHECK_GITHUB_COMMIT: "e575ff318c93add2a6d3f9107a52c5e37c666a98"
+      PACKCHECK_GITHUB_COMMIT: "8c61fb67ee860ad86049ab17e31bfa8f368b73cf"
 
       # Pull token from "secrets" setting of the github repo
       COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }}
@@ -68,184 +69,24 @@ jobs:
       matrix:
         # The order is important to optimize fail-fast.
         name:
-          - 9.10.1-Werror
+          - 9.2.8
         # - 9.8.1-docspec
         # - 8.10.7-coverage
 
         # Note: if cabal.project is not specified benchmarks and tests won't
         # run. But we need at least one test where we test without
         # cabal.project because that is how hackage would build it.
         include:
-          - name: head
-            ghc_version: head
-            # The URL may change, to find a working URL go to https://gitlab.haskell.org/ghc/ghc/-/jobs/
-            # Find a debian10/11/12 job, click on a passed/failed status, at the
-            # end of the output you will find the tar.xz name, put that tar
-            # name after "raw/", and put the job name after "job=".
-            # Also see https://github.com/mpickering/ghc-artefact-nix/blob/master/gitlab-artifact.nix
-            #
-            # May also use ghcup for installing ghc head version, use the
-            # version "LatestNightly", and the following config:
-            # ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
-            ghcup_ghc_options: "-u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-deb10-int_native-validate.tar.xz?job=x86_64-linux-deb10-int_native-validate"
-            runner: ubuntu-latest
-            build: cabal
-            cabal_build_options: "--flag limit-build-mem"
-            cabal_version: 3.12.1.0
-            cabal_project: cabal.project.ghc-head
-            disable_sdist_build: "y"
-            ignore_error: true
-          - name: 9.12.1
-            ghc_version: 9.12.1
-            runner: ubuntu-latest
-            build: cabal
-            cabal_build_options: "--flag limit-build-mem"
-            cabal_version: 3.12.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            ignore_error: false
-          # Note: use linux for warning build for convenient dev testing
-          - name: 9.10.1-Werror
-            ghc_version: 9.10.1
-            runner: ubuntu-latest
-            build: cabal
-            cabal_build_options: "--flag limit-build-mem"
-            cabal_version: 3.12.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project.Werror
-            ignore_error: false
-          - name: 9.10.1-macos
-            ghc_version: 9.10.1
-            runner: macos-latest
-            build: cabal
-            cabal_build_options: "--flag limit-build-mem"
-            cabal_version: 3.12.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            ignore_error: false
-          - name: 9.10.1-fusion-inspection
-            ghc_version: 9.10.1
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.12.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            cabal_build_options: "--flag fusion-plugin --flag inspection"
-            ignore_error: false
-          - name: 9.8.2-macos-stack
-            runner: macos-latest
-            build: stack
-            resolver: nightly-2024-09-26
-            stack_yaml: stack.yaml
-            disable_docs: "y"
-            disable_sdist_build: "y"
-            disable_dist_checks: "y"
-            disable_test: "y"
-            disable_bench: "y"
-            #sdist_options: "--ignore-check"
-            stack_build_options: "-v"
-            cabal_version: 3.12.1.0
-            ignore_error: true
-        # - name: 9.8.1-docspec
-        #   ghc_version: 9.8.1
-        #   runner: ubuntu-latest
-        #   build: cabal
-        #   cabal_version: 3.10.1.0
-        #   cabal_project: cabal.project.doctest
-        #   disable_test: "y"
-        #   disable_bench: "y"
-        #   disable_docs: "y"
-        #   enable_docspec: "y"
-        #   disable_sdist_build: "y"
-        #   ignore_error: false
-          - name: 9.8.1-fusion-inspection
-            ghc_version: 9.8.1
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.12.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            cabal_build_options: "--flag fusion-plugin --flag inspection"
-            ignore_error: false
-          - name: 9.6.3-macos
-            ghc_version: 9.6.3
-            runner: macos-latest
-            build: cabal
-            cabal_version: 3.10.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            ignore_error: false
-          - name: 9.4.7-lstat-readir
-            ghc_version: 9.4.7
-            runner: ubuntu-latest
-            build: cabal
-            cabal_build_options: "--flag force-lstat-readdir"
-            cabal_version: 3.8.1.0
-            disable_sdist_build: "y"
-            cabal_project: cabal.project
-            ignore_error: false
           - name: 9.2.8
             ghc_version: 9.2.8
+            ghcup_ghc_options: "-u https://s3.ap-south-1.amazonaws.com/downloads.portal.composewell.com/ghc/ghc-9.2.8-x86_64-unknown-linux.tar.xz"
             runner: ubuntu-latest
             build: cabal
             cabal_project: cabal.project
             cabal_version: 3.6.2.0
             disable_sdist_build: "y"
             ignore_error: false
-          - name: 9.0.2-streamly-sdist
-            ghc_version: 9.0.2
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.6.2.0
-            cabal_project: cabal.project.streamly
-            ignore_error: true
-          - name: 9.0.2-streamly-core-sdist
-            ghc_version: 9.0.2
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.6.2.0
-            subdir: core
-            ignore_error: false
-          - name: 8.10.7-noopt
-            ghc_version: 8.10.7
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.6.2.0
-            cabal_project: cabal.project
-            disable_sdist_build: "y"
-            disable_docs: "y"
-            disable_dist_checks: "y"
-            cabal_build_options: "--flags \"-opt\""
-            ignore_error: false
-        # - name: 8.10.7-coverage
-        #   ghc_version: 8.10.7
-        #   runner: ubuntu-latest
-        #   coverage: "y"
-        #   cabal_version: 3.6.2.0
-        #   ignore_error: false
-          - name: 8.8.4
-            ghc_version: 8.8.4
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.6.2.0
-            cabal_project: cabal.project
-            disable_sdist_build: "y"
-            disable_docs: "y"
-            ignore_error: false
-          - name: 8.6.5-debug-unoptimized
-            ghc_version: 8.6.5
-            runner: ubuntu-latest
-            build: cabal
-            cabal_version: 3.6.2.0
-            cabal_project: cabal.project
-            cabal_build_options: "--flag debug --flag -opt"
-            disable_sdist_build: "y"
-            disable_docs: "y"
-            ignore_error: false
-        # - name: hlint
-        #   build: hlint
-        #   runner: ubuntu-latest
-        #   ignore_error: true
+            disable_bench: "y"
 
     steps:
     - uses: actions/checkout@v2

test/Streamly/Test/FileSystem/Event.hs

@@ -14,12 +14,15 @@ module Streamly.Test.FileSystem.Event (main) where
 import qualified Streamly.Internal.FileSystem.Event as Event
 import Streamly.Test.FileSystem.Event.Common
 
+tempPrefix :: String
+tempPrefix = "fsevent_common"
+
 moduleName :: String
 moduleName = "FileSystem.Event"
 
 main :: IO ()
 main = do
-    let run = runTests moduleName "non-recursive" Event.watch
+    let run = runTests tempPrefix moduleName "non-recursive" Event.watch
     run DirType commonTests
     run
 #if defined(CABAL_OS_DARWIN)

test/Streamly/Test/FileSystem/Event/Common.hs

@@ -12,6 +12,7 @@ module Streamly.Test.FileSystem.Event.Common
     ( TestDesc
 
     -- * Running tests
+    , runDiagnostics
     , runTests
     , WatchRootType (..)
 
@@ -86,7 +87,7 @@ import Streamly.Internal.FileSystem.Event (Event)
 import qualified Streamly.Internal.FileSystem.Event as Event
 #endif
 
-import Test.Hspec
+-- import Test.Hspec
 
 -------------------------------------------------------------------------------
 -- Check generated events
@@ -153,15 +154,15 @@ data WatchRootType =
                           -- Event contains path via the original symlink
     deriving Show
 
-driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()
-driver checker symlinkStyle (desc, pre, ops, expected) =
-    it desc $ runOneTest `shouldReturn` ()
+-- driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()
+driver :: String -> EventChecker -> WatchRootType -> TestDesc -> IO ()
+driver fseventDir checker symlinkStyle (desc, pre, ops, expected) = do
+    -- it desc $ runOneTest `shouldReturn` ()
+    putStrLn $ "Running: " ++ desc
+    runOneTest
 
     where
 
-    fseventDir :: String
-    fseventDir = "fsevent_dir"
-
     runOneTest = do
             sync <- newEmptyMVar
             withSystemTempDirectory fseventDir $ \fp -> do
@@ -309,31 +310,33 @@ rootDirMove suffix events =
 -- File tests
 -------------------------------------------------------------------------------
 
-createFileWithParent :: FilePath -> FilePath -> IO ()
-createFileWithParent file parent = do
+createFile :: FilePath -> FilePath -> IO ()
+createFile file parent = do
     let filepath = parent </> file
     let dir = takeDirectory filepath
-    putStrLn $ "createFileWithParent: file ["
-        ++ file ++ "] dir [" ++ dir ++ "]"
-    putStrLn $ "Ensuring dir: " ++ dir
-    createDirectoryIfMissing True dir
     r <- doesDirectoryExist dir
     if r
     then do
-        putStrLn $ "Ensured dir: " ++ dir
+        putStrLn $ "createFile: directory exists: " ++ dir
         when (not (null file)) $ do
             exists <- doesFileExist filepath
             if not exists
             then do
-                putStrLn $ "Creating file: " ++ (parent </> file)
+                putStrLn $ "createFile: Creating file: " ++ (parent </> file)
                 openFile (parent </> file) WriteMode >>= hClose
-                putStrLn $ "Created file: " ++ (parent </> file)
-            else error $ "File exists: " ++ filepath
-    else error $ "Could not create dir: " ++ dir
+                putStrLn $ "createFile: Created file: " ++ (parent </> file)
+            else error $ "createFile: File exists: " ++ filepath
+    else error $ "createFile: directory does not exist: " ++ dir
 
-createFile :: FilePath -> FilePath -> IO ()
-createFile file parent =
-    openFile (parent </> file) WriteMode >>= hClose
+createFileWithParent :: FilePath -> FilePath -> IO ()
+createFileWithParent file parent = do
+    let filepath = parent </> file
+    let dir = takeDirectory filepath
+    putStrLn $ "createFileWithParent: file ["
+        ++ file ++ "] dir [" ++ dir ++ "]"
+    putStrLn $ "Ensuring dir: " ++ dir
+    createDirectoryIfMissing True dir
+    createFile file parent
 
 fileCreate :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
 fileCreate file1 events =
@@ -433,16 +436,89 @@ commonRecTests = testsWithParent "subdir"
 runTests ::
        String
     -> String
+    -> String
     -> EventWatcher
     -> WatchRootType
     -> [TestDesc]
     -> IO ()
-runTests modName watchType watcher rootType tests = do
+runTests tempPrefix modName watchType watcher rootType tests = do
+    putStrLn $ "Running tests, module: " ++ modName
+        ++ " watchType: " ++ watchType
     hSetBuffering stdout NoBuffering
+    let checker = checkEvents watcher
+    {-
     hspec
         $ describe modName
         $ describe watchType
         $ do
             let checker = checkEvents watcher
             describe ("Root type " ++ show rootType)
                     $ mapM_ (driver checker rootType) tests
+    -}
+    mapM_ (driver tempPrefix checker rootType) tests
+
+diagDriver :: EventChecker -> TestDesc -> IO ()
+diagDriver checker (desc, pre, ops, expected) = do
+    putStrLn $ "Running diag: " ++ desc
+    sync <- newEmptyMVar
+    withSystemTempDirectory "fsevent_dir_diag" $ \fp -> do
+        let root = fp </> "watch-root-diag"
+        createDirectory root
+
+        -- XXX On macOS we seem to get the watch root create events
+        -- even though they occur before the watch is started.  Even if
+        -- we add a delay here.
+        startWatchAndCheck root sync
+
+    where
+
+    startWatchAndCheck root sync = do
+            putStrLn ("Before pre op: root [" <> root <> "]")
+            pre root
+            putStrLn ("After pre op: root [" <> root <> "]")
+            let check = checker root root sync expected
+                fsOps = Stream.fromEffect $ runFSOps root sync
+            Stream.drain
+                $ Stream.parListEagerFst [Stream.fromEffect check, fsOps]
+
+    runFSOps root sync = do
+        -- We put the MVar before the event watcher starts to run but that does
+        -- not ensure that the event watcher has actually started. So we need a
+        -- delay as well. Do we?
+        takeMVar sync >> threadDelay 200000
+        putStrLn ("Before fs ops: root [" <> root <> "]")
+        ops root
+        putStrLn ("After fs ops: root [" <> root <> "]")
+        threadDelay 10000000
+        error $ root <> ": Time out occurred before event watcher could terminate"
+
+checkDiag :: EventChecker
+checkDiag rootPath targetPath mvar matchList = do
+    putStrLn ("Watching on root [" <> rootPath
+             <> "] for [" <> targetPath <> "]")
+
+    let matchList1 = fmap (first (targetPath </>)) matchList
+        finder xs ev = filter (not . eventMatches ev) xs
+
+    paths <- mapM toUtf8 [rootPath]
+#if defined(FILESYSTEM_EVENT_LINUX)
+    Event.watchWith (Event.setAllEvents True)
+#elif defined(FILESYSTEM_EVENT_DARWIN)
+    Event.watchWith (Event.setAllEvents True)
+#elif defined(FILESYSTEM_EVENT_WINDOWS)
+    Event.watchWith (Event.setAllEvents True)
+#else
+    Event.watch
+#endif
+          (NonEmpty.fromList paths)
+        & Stream.before (putMVar mvar ())
+        & Stream.trace (putStrLn . Event.showEvent)
+        & Stream.scanl' finder matchList1
+        & Stream.takeWhile (not . null)
+        & Stream.drain
+
+runDiagnostics :: [TestDesc] -> IO ()
+runDiagnostics tests = do
+    putStrLn $ "Running diag tests"
+    hSetBuffering stdout NoBuffering
+    mapM_ (diagDriver checkDiag) tests

test/Streamly/Test/FileSystem/Event/Darwin.hs

@@ -14,6 +14,9 @@ import qualified Streamly.Internal.FileSystem.Event.Darwin as Event
 
 import Streamly.Test.FileSystem.Event.Common
 
+tempPrefix :: String
+tempPrefix = "fsevent_darwin"
+
 moduleName :: String
 moduleName = "FileSystem.Event.Darwin"
 
@@ -81,7 +84,7 @@ main = do
             ]
 
     let w = Event.watchWith (Event.setAllEvents True)
-        run = runTests moduleName "recursive" w
+        run = runTests tempPrefix moduleName "recursive" w
 
     run DirType regularRootTests
     run SymLinkResolvedPath symLinkRootTests

test/Streamly/Test/FileSystem/Event/Linux.hs

@@ -10,6 +10,7 @@
 --
 module Streamly.Test.FileSystem.Event.Linux (main) where
 
+-- import Control.Monad (replicateM)
 import Streamly.Internal.FileSystem.Event.Linux (Event)
 -- #if __GLASGOW_HASKELL__ == 902
 #if 1
@@ -21,6 +22,9 @@ import Streamly.Test.FileSystem.Event.Common
 
 #define DEVBUILD
 
+tempPrefix :: String
+tempPrefix = "fsevent_linux"
+
 moduleName :: String
 moduleName = "FileSystem.Event.Linux"
 
@@ -83,6 +87,8 @@ fileMoveEvents src dst =
 
 main :: IO ()
 main = do
+    -- _ <- replicateM 100 $ runDiagnostics [fileCreate "file" fileTouchEvents]
+
     -- We ignore the events on root/parent dir during regular non-root dir/file
     -- tests.
 
@@ -111,7 +117,7 @@ main = do
             regSymTests
 
     let w = Event.watchWith (Event.setAllEvents True)
-        run = runTests moduleName "non-recursive" w
+        run = runTests tempPrefix moduleName "non-recursive" w
 
 #if 1
     let failingTests =
@@ -147,7 +153,7 @@ main = do
 
     let recw = Event.watchWith
                 (Event.setAllEvents True . Event.setRecursiveMode True)
-        runRec = runTests moduleName "recursive" recw
+        runRec = runTests tempPrefix moduleName "recursive" recw
 
 #ifdef DEVBUILD
     -- In recursive mode all subdirectories are roots therefore they will

test/Streamly/Test/FileSystem/Event/Windows.hs

@@ -16,6 +16,9 @@ import Streamly.Test.FileSystem.Event.Common
 moduleName :: String
 moduleName = "FileSystem.Event.Windows"
 
+tempPrefix :: String
+tempPrefix = "fsevent_windows"
+
 -- TODO Test isModified event for parent directories when a file is created or
 -- deleted.
 
@@ -33,7 +36,7 @@ main = do
         -- ++ dirDelete "" (\dir -> [(dir, Event.isDeleted)])
 
     let w = Event.watchWith (Event.setAllEvents True)
-        run = runTests moduleName "non-recursive" w
+        run = runTests tempPrefix moduleName "non-recursive" w
 
     run DirType regularRootTests
     run SymLinkOrigPath commonTests
@@ -47,7 +50,7 @@ main = do
 
     let recw = Event.watchWith
                 (Event.setAllEvents True . Event.setRecursiveMode True)
-        runRec = runTests moduleName "recursive" recw
+        runRec = runTests tempPrefix moduleName "recursive" recw
 
     runRec DirType (regularRootTests ++ recTests)
     runRec SymLinkOrigPath (commonTests ++ recTests)