Test a simple loop with a changing file

feedback-test-harness/default.nix

@@ -1,5 +1,5 @@
-{ mkDerivation, base, feedback, lib, path, path-io, sydtest
-, sydtest-discover, typed-process
+{ mkDerivation, base, bytestring, feedback, lib, path, path-io
+, sydtest, sydtest-discover, typed-process, unix
 }:
 mkDerivation {
   pname = "feedback-test-harness";
@@ -7,7 +7,7 @@ mkDerivation {
   src = ./.;
   libraryHaskellDepends = [ base feedback path path-io ];
   testHaskellDepends = [
-    base feedback path path-io sydtest typed-process
+    base bytestring path path-io sydtest typed-process unix
   ];
   testToolDepends = [ sydtest-discover ];
   doHaddock = false;

feedback-test-harness/feedback-test-harness.cabal

@@ -48,10 +48,11 @@ test-suite feedback-test
       sydtest-discover:sydtest-discover
   build-depends:
       base >=4.7 && <5
-    , feedback
+    , bytestring
     , feedback-test-harness
     , path
     , path-io
     , sydtest
     , typed-process
+    , unix
   default-language: Haskell2010

feedback-test-harness/package.yaml

@@ -13,9 +13,9 @@ dependencies:
 library:
   source-dirs: src
   dependencies:
-  - feedback
   - path
   - path-io
+  - feedback
 
 tests:
   feedback-test:
@@ -28,9 +28,10 @@ tests:
     - -with-rtsopts=-N
     - -Wall
     dependencies:
-    - feedback
+    - bytestring
     - feedback-test-harness
     - path
     - path-io
     - sydtest
     - typed-process
+    - unix

feedback-test-harness/test/FeedbackSpec.hs

@@ -1,35 +1,142 @@
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module FeedbackSpec (spec) where
 
 import Control.Concurrent
+import qualified Data.ByteString as SB
 import Path
 import Path.IO
+import System.IO
+import System.Posix
 import System.Process.Typed
 import Test.Syd
 import Test.Syd.Path
 
 spec :: Spec
-spec = sequential . tempDirSpec "feedback" $ do
+spec = sequential . tempDirSpec "feedback" . coverageSpec $ do
+  let waitABit = threadDelay 250_000 -- Wait 250 ms
   it "can show help text" $ \tdir -> do
-    let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["--help"]
+    let cp =
+          setStdout nullStream
+            . setWorkingDir (fromAbsDir tdir)
+            $ proc "feedback" ["--help"]
     runProcess_ cp :: IO ()
 
   it "can start a loop and wait for input" $ \tdir -> do
-    let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["echo", "hi"]
+    let cp =
+          setStdout nullStream
+            . setWorkingDir (fromAbsDir tdir)
+            $ proc "feedback" ["echo", "hi"]
     withProcessTerm cp $ \ph -> do
-      threadDelay 100_000 -- Wait 100 ms
+      waitABit
       -- If the program is still running after 100ms, we assume that it is waiting.
       mExitCode <- getExitCode ph
       mExitCode `shouldBe` Nothing
-  -- TODO get rid of the fatal.
-  it "can run a command once, wait for input" $ \tdir -> do
-    dateFile <- resolveFile tdir "datefile"
-    let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile]
-    withProcessTerm cp $ \ph -> do
-      threadDelay 100_000 -- Wait 100 ms
-      -- If the program is still running after 100ms, we assume that it is waiting.
-      mExitCode <- getExitCode ph
-      mExitCode `shouldBe` Nothing
-    readFile (fromAbsFile dateFile) >>= print
-  pending "can run a command once, wait for input, and run it again upon input, and then still be running"
+
+  it "can run a command once, wait for input" $ \tdir ->
+    withSystemTempDir "somewhere-else" $ \otherTDir -> do
+      resultFile <- resolveFile otherTDir "result" -- In another dir so the loop doesn't rerun automatically
+      let cp =
+            setStdout nullStream
+              . setWorkingDir (fromAbsDir tdir)
+              $ proc "feedback" ["--", "bash", "-c", "echo hi >" <> fromAbsFile resultFile]
+      withProcessTerm cp $ \ph -> do
+        waitABit
+
+        result <- SB.readFile (fromAbsFile resultFile)
+        result `shouldBe` "hi\n"
+
+        -- If the program is still running after 100ms, we assume that it is waiting.
+        mExitCode <- getExitCode ph
+        mExitCode `shouldBe` Nothing
+
+  it "can run a command once, wait for manual input, and run it again upon input, and then still be running" $ \tdir ->
+    withSystemTempDir "somewhere-else" $ \otherTDir -> do
+      -- In another dir so the loop doesn't rerun automatically
+      dateFile <- resolveFile otherTDir "datefile"
+
+      (masterFd, slaveFd) <- openPseudoTerminal
+      masterHandle <- fdToHandle masterFd
+      slaveHandle <- fdToHandle slaveFd
+
+      let cp =
+            setStdout nullStream
+              . setStdin (useHandleOpen slaveHandle)
+              . setWorkingDir (fromAbsDir tdir)
+              $ proc "feedback" ["--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile]
+      withProcessTerm cp $ \ph -> do
+        waitABit
+
+        -- Feedback is running.
+        mExitCode <- getExitCode ph
+        mExitCode `shouldBe` Nothing
+
+        beforeContents <- SB.readFile (fromAbsFile dateFile)
+
+        hPutChar masterHandle 'r'
+        hFlush masterHandle
+
+        waitABit
+
+        afterContents <- SB.readFile (fromAbsFile dateFile)
+        afterContents `shouldNotBe` beforeContents
+
+  it "can run a command once, wait for a file to change, and run it again upon input, and then still be running" $ \tdir ->
+    withSystemTempDir "somewhere-else" $ \otherTDir -> do
+      -- In another dir so the loop doesn't rerun automatically
+      dateFile <- resolveFile otherTDir "datefile"
+
+      -- In the same dir so the loop reruns when we change it
+      triggerFile <- resolveFile tdir "trigger"
+      SB.writeFile (fromAbsFile triggerFile) "initial"
+
+      (_, slaveFd) <- openPseudoTerminal
+      -- masterHandle <- fdToHandle masterFd
+      slaveHandle <- fdToHandle slaveFd
+
+      let cp =
+            setStdout nullStream
+              . setStdin (useHandleOpen slaveHandle)
+              . setWorkingDir (fromAbsDir tdir)
+              $ proc "feedback" ["--no-clear", "--debug", "--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile]
+      withProcessTerm cp $ \ph -> do
+        waitABit
+
+        -- Feedback is running.
+        mExitCode <- getExitCode ph
+        mExitCode `shouldBe` Nothing
+
+        -- Make sure the file exists now
+        beforeContents <- SB.readFile (fromAbsFile dateFile)
+
+        -- Change the trigger file, this should cause the loop to rerun.
+        SB.writeFile (fromAbsFile triggerFile) "go go go"
+
+        -- Make sure the loop is rerun
+        waitABit
+
+        -- Make sure the loop is rerun
+        afterContents <- SB.readFile (fromAbsFile dateFile)
+        afterContents `shouldNotBe` beforeContents
+
+        waitABit
+
+-- It's really annoying that this is necessary, but hear me out.
+-- `feedback` is run in a tempdir.
+-- When instrumented with coverage tooling, it will output 'coverage.dat' its
+-- working dir.
+-- We have to copy back the coverage info in order to make the coverage report.
+--
+-- It's slow and dirty but it works.
+coverageSpec :: SpecWith (Path Abs Dir) -> SpecWith (Path Abs Dir)
+coverageSpec = after $ \tdir -> do
+  specificCoverageFile <- resolveFile tdir "coverage.dat"
+  topLevelCoverageFile <- resolveFile' "coverage.dat"
+  mSpecificCoverage <- forgivingAbsence $ SB.readFile (fromAbsFile specificCoverageFile)
+  mTopLevelCoverage <- forgivingAbsence $ SB.readFile (fromAbsFile topLevelCoverageFile)
+  SB.writeFile (fromAbsFile topLevelCoverageFile) $ case (mTopLevelCoverage, mSpecificCoverage) of
+    (Nothing, Nothing) -> mempty
+    (Just topLevelCoverage, Nothing) -> topLevelCoverage
+    (Nothing, Just specificCoverage) -> specificCoverage
+    (Just topLevelCoverage, Just specificCoverage) -> topLevelCoverage <> specificCoverage

feedback.yaml

@@ -10,3 +10,11 @@ loops:
   test:
     description: Work on `feedback-test`
     command: cabal run feedback:feedback-test
+
+  test-harness:
+    description: Work on `feedback-test-harness`
+    script: |
+      cabal build feedback:exe:feedback
+      bindir=$(dirname $(cabal list-bin feedback:exe:feedback))
+      export PATH="$bindir:$PATH"
+      cabal test feedback-test-harness

feedback/src/Feedback/Loop.hs

@@ -25,17 +25,17 @@ import System.FSNotify as FS
 import System.IO (hGetChar)
 import System.Mem (performGC)
 import System.Posix.Signals as Signal
+import Text.Colour
+import UnliftIO
 #ifdef MIN_VERSION_Win32
 import System.Win32.MinTTY (isMinTTYHandle)
 import System.Win32.Types (withHandleToHANDLE)
 #endif
-import Text.Colour
 #ifdef MIN_VERSION_safe_coloured_text_terminfo
 import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
 #else
 import Text.Colour.Capabilities (TerminalCapabilities(..))
 #endif
-import UnliftIO
 
 runFeedbackLoop :: IO ()
 runFeedbackLoop = do

feedback/src/Feedback/Loop/Filter.hs

@@ -92,7 +92,9 @@ mkGitFilter here FilterSettings {..} = do
 
 gitLsFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
 gitLsFiles here = do
-  let processConfig = shell "git ls-files"
+  -- If there is no git directory, we'll get a 'fatal' message on stderr.
+  -- We don't need the user to see this, so we setStderr nullStream.
+  let processConfig = setStderr nullStream $ shell "git ls-files"
   (ec, out) <- readProcessStdout processConfig
   set <- bytesFileSet here out
   pure $ case ec of

nix/overlay.nix

@@ -13,44 +13,46 @@ with final.haskell.lib;
 
   haskellPackages = prev.haskellPackages.override (old: {
     overrides = composeExtensions (old.overrides or (_: _: { })) (
-      self: super:
-        {
-          feedback-test-harness = addBuildDepend (self.callPackage ../feedback-test-harness { }) final.feedback;
-          feedback = generateOptparseApplicativeCompletion "feedback" (
-            buildFromSdist (overrideCabal
-              (
-                self.callPackage
-                  ../feedback
-                  { }
-              )
-              (old: {
-                doBenchmark = true;
-                doHaddock = true;
-                doCoverage = false;
-                doHoogle = true;
-                hyperlinkSource = false;
-                enableLibraryProfiling = false;
-                enableExecutableProfiling = false;
+      self: super: {
+        feedback = generateOptparseApplicativeCompletion "feedback" (
+          buildFromSdist (overrideCabal
+            (
+              self.callPackage
+                ../feedback
+                { }
+            )
+            (old: {
+              doBenchmark = true;
+              doHaddock = true;
+              doCoverage = false;
+              doHoogle = true;
+              doCheck = false;
+              hyperlinkSource = false;
+              enableLibraryProfiling = false;
+              enableExecutableProfiling = false;
 
-                configureFlags = (old.configureFlags or [ ]) ++ [
-                  # Optimisations
-                  "--ghc-options=-O2"
-                  # Extra warnings
-                  "--ghc-options=-Wall"
-                  "--ghc-options=-Wincomplete-uni-patterns"
-                  "--ghc-options=-Wincomplete-record-updates"
-                  "--ghc-options=-Wpartial-fields"
-                  "--ghc-options=-Widentities"
-                  "--ghc-options=-Wredundant-constraints"
-                  "--ghc-options=-Wcpp-undef"
-                  "--ghc-options=-Werror"
-                  "--ghc-options=-optP-Wno-nonportable-include-path" # For macos
-                ];
-                # Ugly hack because we can't just add flags to the 'test' invocation.
-                # Show test output as we go, instead of all at once afterwards.
-                testTarget = (old.testTarget or "") + " --show-details=direct";
-              })));
-        }
+              configureFlags = (old.configureFlags or [ ]) ++ [
+                # Optimisations
+                "--ghc-options=-O2"
+                # Extra warnings
+                "--ghc-options=-Wall"
+                "--ghc-options=-Wincomplete-uni-patterns"
+                "--ghc-options=-Wincomplete-record-updates"
+                "--ghc-options=-Wpartial-fields"
+                "--ghc-options=-Widentities"
+                "--ghc-options=-Wredundant-constraints"
+                "--ghc-options=-Wcpp-undef"
+                "--ghc-options=-Werror"
+                "--ghc-options=-optP-Wno-nonportable-include-path" # For macos
+              ];
+            })));
+        feedback-test-harness = buildStrictly
+          (overrideCabal (self.callPackage ../feedback-test-harness { }) (old: {
+            # Ugly hack because we can't just add flags to the 'test' invocation.
+            # Show test output as we go, instead of all at once afterwards.
+            testTarget = (old.testTarget or "") + " --show-details=direct";
+          }));
+      }
     );
   });
 }