Use file monitoring for pre-processor re-run checks (#11411)

Cabal-syntax/src/Distribution/Utils/Structured.hs

@@ -77,6 +77,7 @@ import qualified Control.Monad.Trans.State.Strict as State
 
 import Control.Exception (ErrorCall (..), catch, evaluate)
 
+import GHC.Fingerprint
 import GHC.Generics
 
 import qualified Data.ByteString as BS
@@ -391,6 +392,8 @@ instance Structured Integer where structure = nominalStructure
 
 instance Structured Data.Word.Word where structure = nominalStructure
 
+instance Structured Fingerprint
+
 instance Structured Int8 where structure = nominalStructure
 instance Structured Int16 where structure = nominalStructure
 instance Structured Int32 where structure = nominalStructure

Cabal-tests/Cabal-tests.cabal

@@ -202,6 +202,30 @@ test-suite no-thunks-test
     build-depends:
       , nothunks >=0.1.1.0 && <0.3
 
+-- Slow, long-running tests
+test-suite long-tests
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   tests
+  other-modules:
+    Test.Laws
+    UnitTests.Options
+    UnitTests.Distribution.Simple.FileMonitor
+
+  main-is:          LongTests.hs
+  build-depends:
+    , base                >=4.17    && <5
+    , Cabal
+    , Cabal-syntax
+    , containers
+    , directory           >=1.2.7
+    , filepath
+    , tasty               >=1.2.3 && <1.6
+    , tasty-expected-failure
+    , tasty-hunit
+
+  ghc-options:      -Wall
+  default-language: Haskell2010
+
 executable ghc-supported-extensions
   hs-source-dirs:   exes
   main-is:          GhcSupportedExtensions.hs

Cabal-tests/tests/LongTests.hs

@@ -0,0 +1,21 @@
+module Main (main) where
+
+import Test.Tasty
+
+import qualified UnitTests.Distribution.Simple.FileMonitor
+import UnitTests.Options
+
+main :: IO ()
+main =
+  defaultMainWithIngredients
+    (includingOptions extraOptions : defaultIngredients)
+    tests
+
+tests :: TestTree
+tests =
+  askOption $ \(OptionMtimeChangeDelay mtimeChange) ->
+    testGroup
+      "Long-running tests"
+      [ testGroup "UnitTests.Distribution.Simple.FileMonitor" $
+          UnitTests.Distribution.Simple.FileMonitor.tests mtimeChange
+      ]

cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs → Cabal-tests/tests/UnitTests/Distribution/Simple/FileMonitor.hs

@@ -1,4 +1,4 @@
-module UnitTests.Distribution.Client.FileMonitor (tests) where
+module UnitTests.Distribution.Simple.FileMonitor (tests) where
 
 import Distribution.Parsec (simpleParsec)
 
@@ -16,8 +16,8 @@ import Distribution.Compat.Binary
 import Distribution.Simple.Utils (removeFileForcibly, withTempDirectory)
 import Distribution.System (OS (Windows), buildOS)
 
-import Distribution.Client.FileMonitor
 import Distribution.Compat.Time
+import Distribution.Simple.FileMonitor
 import Distribution.Utils.Structured (Structured, structureHash)
 import GHC.Fingerprint (Fingerprint (..))
 
@@ -29,7 +29,7 @@ tests :: Int -> [TestTree]
 tests mtimeChange =
   [ testGroup
       "Structured hashes"
-      [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe1339b9dcfdfe19d 0x9135a5f30da7ca82
+      [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint fingerprintStateFile1 fingerprintStateFile2
       , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint fingerprintStateGlob1 fingerprintStateGlob2
       , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint fingerprintStateFileSet1 fingerprintStateFileSet2
       ]
@@ -94,11 +94,13 @@ tests mtimeChange =
     knownBrokenInWindows msg = case buildOS of
       Windows -> expectFailBecause msg
       _ -> id
-    fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64
-    fingerprintStateGlob1 = 0x5d9efec2b93d22a1
-    fingerprintStateGlob2 = 0xfdbc86351866a191
-    fingerprintStateFileSet1 = 0x4cee0a3a23697bb1
-    fingerprintStateFileSet2 = 0x96039d15c3241985
+    fingerprintStateFile1, fingerprintStateFile2, fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64
+    fingerprintStateFile1 = 0x982ee8fef06a3b5f
+    fingerprintStateFile2 = 0xe3c608811ccf1011
+    fingerprintStateGlob1 = 0xd17eeece5373667b
+    fingerprintStateGlob2 = 0x0b8d8ed7d6a103e8
+    fingerprintStateFileSet1 = 0xb1555b75c3f96850
+    fingerprintStateFileSet2 = 0x4a51468742b6452b
 
 -- Check the file system behaves the way we expect it to
 

Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs

@@ -1,22 +1,29 @@
 {-# LANGUAGE LambdaCase #-}
+
 module UnitTests.Distribution.Simple.Glob
-    ( tests
-    ) where
-
-import Control.Monad
-import Data.Foldable (for_)
-import Data.Function (on)
-import Data.List (sort)
-import Data.Maybe (mapMaybe)
-import Distribution.Simple.Glob
-import qualified Distribution.Verbosity as Verbosity
+  ( tests
+  ) where
+
+import Distribution.Compat.Prelude hiding (last)
+import Prelude ()
+
 import Distribution.CabalSpecVersion
+import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Simple.FileMonitor.Types
+import Distribution.Simple.Glob
+import Distribution.Simple.Glob.Internal
+import Distribution.Utils.Structured (structureHash)
+import Distribution.Verbosity
+import Distribution.Verbosity qualified as Verbosity
+import GHC.Fingerprint
 import System.Directory (createDirectoryIfMissing)
-import System.FilePath ((</>), splitFileName, normalise)
+import System.FilePath (normalise, splitFileName, (</>))
 import System.IO.Temp (withSystemTempDirectory)
+import Test.QuickCheck.Instances.Cabal ()
 import Test.Tasty
 import Test.Tasty.HUnit
-import Distribution.Verbosity
+import Test.Tasty.QuickCheck
 
 sampleFileNames :: [FilePath]
 sampleFileNames =
@@ -51,6 +58,134 @@ makeSampleFiles dir = for_ sampleFileNames $ \filename -> do
   createDirectoryIfMissing True (dir </> dir')
   writeFile (dir </> dir' </> name) $ "This is " ++ filename
 
+prop_roundtrip_printparse :: RootedGlob -> Property
+prop_roundtrip_printparse pathglob =
+  counterexample (prettyShow pathglob) $
+    eitherParsec (prettyShow pathglob) === Right pathglob
+
+-- first run, where we don't even call updateMonitor
+testParseCases :: Assertion
+testParseCases = do
+  RootedGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
+  RootedGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
+
+  RootedGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
+  RootedGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
+  RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
+  RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
+
+  RootedGlob
+    FilePathRelative
+    (GlobDirRecursive [WildCard]) <-
+    testparse "**/*"
+  RootedGlob
+    FilePathRelative
+    (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard])) <-
+    testparse "foo/**/*"
+  RootedGlob
+    FilePathRelative
+    (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard, Literal ".txt"])) <-
+    testparse "foo/**/*.txt"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [Literal "."]) <-
+    testparse "."
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [Literal "~"]) <-
+    testparse "~"
+
+  RootedGlob
+    FilePathRelative
+    (GlobDir [Literal "."] GlobDirTrailing) <-
+    testparse "./"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [Literal "foo"]) <-
+    testparse "foo"
+
+  RootedGlob
+    FilePathRelative
+    ( GlobDir
+        [Literal "foo"]
+        (GlobFile [Literal "bar"])
+      ) <-
+    testparse "foo/bar"
+
+  RootedGlob
+    FilePathRelative
+    ( GlobDir
+        [Literal "foo"]
+        (GlobDir [Literal "bar"] GlobDirTrailing)
+      ) <-
+    testparse "foo/bar/"
+
+  RootedGlob
+    (FilePathRoot "/")
+    ( GlobDir
+        [Literal "foo"]
+        (GlobDir [Literal "bar"] GlobDirTrailing)
+      ) <-
+    testparse "/foo/bar/"
+
+  RootedGlob
+    (FilePathRoot "C:\\")
+    ( GlobDir
+        [Literal "foo"]
+        (GlobDir [Literal "bar"] GlobDirTrailing)
+      ) <-
+    testparse "C:\\foo\\bar\\"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [WildCard]) <-
+    testparse "*"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [WildCard, WildCard]) <-
+    testparse "**" -- not helpful, but valid (?)
+  RootedGlob
+    FilePathRelative
+    (GlobFile [WildCard, Literal "foo", WildCard]) <-
+    testparse "*foo*"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [Literal "foo", WildCard, Literal "bar"]) <-
+    testparse "foo*bar"
+
+  RootedGlob
+    FilePathRelative
+    (GlobFile [Union [[WildCard], [Literal "foo"]]]) <-
+    testparse "{*,foo}"
+
+  parseFail "{"
+  parseFail "}"
+  parseFail ","
+  parseFail "{"
+  parseFail "{{}"
+  parseFail "{}"
+  parseFail "{,}"
+  parseFail "{foo,}"
+  parseFail "{,foo}"
+
+  return ()
+
+testparse :: String -> IO RootedGlob
+testparse s =
+  case eitherParsec s of
+    Right p -> return p
+    Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err)
+
+parseFail :: String -> Assertion
+parseFail s =
+  case eitherParsec s :: Either String RootedGlob of
+    Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)
+    Left _ -> return ()
 compatibilityTests :: CabalSpecVersion -> [TestTree]
 compatibilityTests version =
   [ testCase "literal match" $
@@ -109,19 +244,23 @@ testMatchesVersion version pat expected = do
           -- check can't identify that kind of match.
           expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected
       unless (sort expected' == sort actual) $
-        assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
+        assertFailure $
+          "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
     checkIO globPat =
       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
         makeSampleFiles tmpdir
         actual <- runDirFileGlob verbosity (Just version) tmpdir globPat
         unless (isEqual actual expected) $
-          assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
+          assertFailure $
+            "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
 
 testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion
 testFailParseVersion version pat expected =
   case parseFileGlob version pat of
-    Left err -> unless (expected == err) $
-      assertFailure $ "Unexpected error: " ++ show err
+    Left err ->
+      unless (expected == err) $
+        assertFailure $
+          "Unexpected error: " ++ show err
     Right _ -> assertFailure "Unexpected success in parsing."
 
 globstarTests :: [TestTree]
@@ -157,9 +296,25 @@ multiDotTests =
   where
     testMatches = testMatchesVersion CabalSpecV2_4
 
+printParseTests :: [TestTree]
+printParseTests =
+  [ testProperty "print/parse roundtrip" prop_roundtrip_printparse
+  , testCase "parse examples" testParseCases
+  , testGroup
+      "Structured hashes"
+      [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782
+      , testCase "Glob" $ structureHash (Proxy :: Proxy Glob) @?= Fingerprint 0x3a5af41e8194eaa3 0xd8e461fdfdb0e07b
+      , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5
+      , testCase "RootedGlob" $ structureHash (Proxy :: Proxy RootedGlob) @?= Fingerprint 0x0031d198379cd1bf 0x7246ab9b6c6e0e7d
+      ]
+  ]
+
 tests :: [TestTree]
 tests =
-  [ testGroup "pre-2.4 compatibility" $
+  [ testGroup
+      "print/parse"
+      printParseTests
+  , testGroup "pre-2.4 compatibility" $
       compatibilityTests CabalSpecV2_2
   , testGroup "post-2.4 compatibility" $
       compatibilityTests CabalSpecV2_4
@@ -168,3 +323,5 @@ tests =
       testFailParseVersion CabalSpecV1_4 "foo/*.bar" VersionDoesNotSupportGlob
   , testGroup "multi-dot globbing" multiDotTests
   ]
+
+-- TODO: tests for windows style file paths

Cabal-tests/tests/UnitTests/Options.hs

@@ -0,0 +1,30 @@
+module UnitTests.Options
+  ( OptionMtimeChangeDelay (..)
+  , extraOptions
+  )
+where
+
+import Data.Proxy
+
+import Test.Tasty.Options
+
+{-------------------------------------------------------------------------------
+  Test options
+-------------------------------------------------------------------------------}
+
+extraOptions :: [OptionDescription]
+extraOptions =
+  [ Option (Proxy :: Proxy OptionMtimeChangeDelay)
+  ]
+
+newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int
+
+instance IsOption OptionMtimeChangeDelay where
+  defaultValue = OptionMtimeChangeDelay 10000
+  showDefaultValue (OptionMtimeChangeDelay v) = Just (show v)
+  parseValue = fmap OptionMtimeChangeDelay . safeRead
+  optionName = return "mtime-change-delay"
+  optionHelp =
+    return $
+      "How long to wait before attempting to detect"
+        ++ "file modification, in microseconds"