Mattp/glob and preproc

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

@@ -107,13 +107,13 @@ 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
+        assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
     checkIO globPat =
       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
         makeSampleFiles tmpdir
         actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
         unless (isEqual actual expected) $
-          assertFailure $ "Unexpected result (impure matcher): " ++ show actual
+          assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
 
 testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion
 testFailParseVersion version pat expected =

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -65,7 +65,6 @@ import Distribution.Simple.Glob
   ( Glob
   , GlobResult (..)
   , globMatches
-  , parseFileGlob
   , runDirFileGlob
   )
 import Distribution.Simple.Utils hiding (findPackageDesc, notice)
@@ -268,8 +267,6 @@ checkGenericPackageDescription
       checkP
         (not . null $ dups names)
         (PackageBuildImpossible $ DuplicateSections dupes)
-      -- PackageDescription checks.
-      checkPackageDescription packageDescription_
       -- Flag names.
       mapM_ checkFlagName genPackageFlags_
 
@@ -465,20 +462,6 @@ checkPackageDescription
     mapM_ (checkPath False "license-file" PathKindFile) licPaths
     mapM_ checkLicFileExist licenseFiles_
 
-    -- § Globs.
-    dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_
-    extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_
-    docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_
-    extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_
-    -- We collect globs to feed them to checkMissingDocs.
-
-    -- § Missing documentation.
-    checkMissingDocs
-      (catMaybes dataGlobs)
-      (catMaybes extraSrcGlobs)
-      (catMaybes docGlobs)
-      (catMaybes extraGlobs)
-
     -- § Datafield checks.
     checkSetupBuildInfo setupBuildInfo_
     mapM_ checkTestedWith testedWith_
@@ -517,14 +500,27 @@ checkPackageDescription
       (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks])
       (PackageBuildWarning NoCustomSetup)
 
+    -- § Globs.
+    dataGlobs <- catMaybes <$> mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_
+    extraSrcGlobs <- catMaybes <$> mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_
+    docGlobs <- catMaybes <$> mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_
+    extraGlobs <- catMaybes <$> mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_
+
     -- Contents.
     checkConfigureExists (buildType pkg)
     checkSetupExists (buildType pkg)
     checkCabalFile (packageName pkg)
-    mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_
-    mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_
-    mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_
-    mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_
+    extraSrcFilesGlobResults <- mapM (checkGlobFile "." "extra-source-files") extraSrcGlobs
+    extraDocFilesGlobResults <- mapM (checkGlobFile "." "extra-doc-files") docGlobs
+    extraFilesGlobResults <- mapM (checkGlobFile "." "extra-files") extraGlobs
+    extraDataFilesGlobResults <- mapM (checkGlobFile rawDataDir "data-files") dataGlobs
+
+    -- § Missing documentation.
+    checkMissingDocs
+      extraDataFilesGlobResults
+      extraSrcFilesGlobResults
+      extraDocFilesGlobResults
+      extraFilesGlobResults
     where
       checkNull
         :: Monad m
@@ -845,29 +841,28 @@ checkSetupExists _ =
 
 checkGlobFile
   :: Monad m
-  => CabalSpecVersion
-  -> FilePath -- Glob pattern.
-  -> FilePath -- Folder to check.
+  => FilePath -- Folder to check.
   -> CabalField -- .cabal field we are checking.
-  -> CheckM m ()
-checkGlobFile cv ddir title fp = do
+  -> Glob -- Glob pattern.
+  -> CheckM m [GlobResult FilePath]
+checkGlobFile ddir title parsedGlob = do
   let adjDdir = if null ddir then "." else ddir
       dir
         | title == "data-files" = adjDdir
         | otherwise = "."
-
-  case parseFileGlob cv fp of
-    -- We just skip over parse errors here; they're reported elsewhere.
-    Left _ -> return ()
-    Right parsedGlob -> do
-      liftInt ciPreDistOps $ \po -> do
-        rs <- runDirFileGlobM po dir parsedGlob
-        return $ checkGlobResult title fp rs
+  mpo <- asksCM (ciPreDistOps . ccInterface)
+  case mpo of
+    Nothing ->
+      pure []
+    Just po -> do
+      rs <- liftCM $ runDirFileGlobM po dir parsedGlob
+      mapM_ tellP (checkGlobResult title parsedGlob rs)
+      return rs
 
 -- | Checks for matchless globs and too strict matching (<2.4 spec).
 checkGlobResult
   :: CabalField -- .cabal field we are checking
-  -> FilePath -- Glob pattern (to show the user
+  -> Glob -- Glob pattern (to show the user
   -- which pattern is the offending
   -- one).
   -> [GlobResult FilePath] -- List of glob results.
@@ -876,7 +871,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
   where
     dirCheck
       | all (not . withoutNoMatchesWarning) rs =
-          [PackageDistSuspiciousWarn $ GlobNoMatch title fp]
+          [PackageDistSuspiciousWarn $ GlobNoMatch title (prettyShow fp)]
       | otherwise = []
 
     -- If there's a missing directory in play, since globs in Cabal packages
@@ -895,9 +890,9 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
     -- suffix. This warning detects when pre-2.4 package descriptions
     -- are omitting files purely because of the stricter check.
     getWarning (GlobWarnMultiDot file) =
-      Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)
+      Just $ PackageDistSuspiciousWarn (GlobExactMatch title (prettyShow fp) file)
     getWarning (GlobMissingDirectory dir) =
-      Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)
+      Just $ PackageDistSuspiciousWarn (GlobNoDir title (prettyShow fp) dir)
     -- GlobMatchesDirectory is handled elsewhere if relevant;
     -- we can discard it here.
     getWarning (GlobMatchesDirectory _) = Nothing
@@ -999,10 +994,10 @@ pd2gpd pd = gpd
 -- present in our .cabal file.
 checkMissingDocs
   :: Monad m
-  => [Glob] -- data-files globs.
-  -> [Glob] -- extra-source-files globs.
-  -> [Glob] -- extra-doc-files globs.
-  -> [Glob] -- extra-files globs.
+  => [[GlobResult FilePath]] -- data-files globs.
+  -> [[GlobResult FilePath]] -- extra-source-files globs.
+  -> [[GlobResult FilePath]] -- extra-doc-files globs.
+  -> [[GlobResult FilePath]] -- extra-files globs.
   -> CheckM m ()
 checkMissingDocs dgs esgs edgs efgs = do
   extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion
@@ -1018,12 +1013,11 @@ checkMissingDocs dgs esgs edgs efgs = do
 
         -- 2. Realise Globs.
         let realGlob t =
-              concatMap globMatches
-                <$> mapM (runDirFileGlobM ops "") t
-        rgs <- realGlob dgs
-        res <- realGlob esgs
-        red <- realGlob edgs
-        ref <- realGlob efgs
+              concatMap globMatches t
+        let rgs = realGlob dgs
+        let res = realGlob esgs
+        let red = realGlob edgs
+        let ref = realGlob efgs
 
         -- 3. Check if anything in 1. is missing in 2.
         let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red ++ ref)

Cabal/src/Distribution/PackageDescription/Check/Monad.hs

@@ -37,6 +37,7 @@ module Distribution.PackageDescription.Check.Monad
   , checkP
   , checkPkg
   , liftInt
+  , liftCM
   , tellP
   , checkSpecVer
   ) where

Cabal/src/Distribution/Simple/Glob.hs

@@ -370,7 +370,6 @@ runDirFileGlob verbosity mspec rawRoot pat = do
       "Null dir passed to runDirFileGlob; interpreting it "
         ++ "as '.'. This is probably an internal error."
   let root = if null rawRoot then "." else rawRoot
-  debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
   -- This function might be called from the project root with dir as
   -- ".". Walking the tree starting there involves going into .git/
   -- and dist-newstyle/, which is a lot of work for no reward, so
@@ -379,7 +378,7 @@ runDirFileGlob verbosity mspec rawRoot pat = do
   -- the whole directory if *, and just the specific file if it's a
   -- literal.
   let
-    (prefixSegments, variablePattern) = splitConstantPrefix pat
+    (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat
     joinedPrefix = joinPath prefixSegments
 
     -- The glob matching function depends on whether we care about the cabal version or not
@@ -431,17 +430,37 @@ runDirFileGlob verbosity mspec rawRoot pat = do
       concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
     go GlobDirTrailing dir = return [GlobMatch dir]
 
-  directoryExists <- doesDirectoryExist (root </> joinedPrefix)
-  if directoryExists
-    then go variablePattern joinedPrefix
-    else return [GlobMissingDirectory joinedPrefix]
+  case pathOrVariablePattern of
+    Left filename -> do
+      let filepath = joinedPrefix </> filename
+      debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'."
+      directoryExists <- doesDirectoryExist (root </> filepath)
+      if directoryExists
+        then pure [GlobMatchesDirectory filepath]
+        else do
+          exist <- doesFileExist (root </> filepath)
+          pure $
+            if exist
+              then [GlobMatch filepath]
+              else []
+    Right variablePattern -> do
+      debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."
+      directoryExists <- doesDirectoryExist (root </> joinedPrefix)
+      if directoryExists
+        then go variablePattern joinedPrefix
+        else return [GlobMissingDirectory joinedPrefix]
   where
     -- \| Extract the (possibly null) constant prefix from the pattern.
     -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
     -- then @pat === foldr GlobDir final pref@.
-    splitConstantPrefix :: Glob -> ([FilePath], Glob)
-    splitConstantPrefix = unfoldr' step
+    splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob)
+    splitConstantPrefix = fmap literalize . unfoldr' step
       where
+        literalize (GlobFile [Literal filename]) =
+          Left filename
+        literalize glob =
+          Right glob
+
         step (GlobDir [Literal seg] pat') = Right (seg, pat')
         step pat' = Left pat'
 

Cabal/src/Distribution/Simple/PreProcess.hs

@@ -292,63 +292,66 @@ preprocessFile
   -- ^ fail on missing file
   -> IO ()
 preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do
-  -- look for files in the various source dirs with this module name
-  -- and a file extension of a known preprocessor
-  psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile
-  case psrcFiles of
-    -- no preprocessor file exists, look for an ordinary source file
-    -- just to make sure one actually exists at all for this module.
-
-    -- Note [Dodgy build dirs for preprocessors]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- By looking in the target/output build dir too, we allow
-    -- source files to appear magically in the target build dir without
-    -- any corresponding "real" source file. This lets custom Setup.hs
-    -- files generate source modules directly into the build dir without
-    -- the rest of the build system being aware of it (somewhat dodgy)
+  bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile
+  case bsrcFiles of
+    -- found a non-processable file in one of the source dirs
+    Just _ -> do
+      pure ()
     Nothing -> do
-      bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile
-      case (bsrcFiles, failOnMissing) of
-        (Nothing, True) ->
-          dieWithException verbosity $
-            CantFindSourceForPreProcessFile $
-              "can't find source for "
-                ++ getSymbolicPath baseFile
-                ++ " in "
-                ++ intercalate ", " (map getSymbolicPath searchLoc)
-        _ -> return ()
-    -- found a pre-processable file in one of the source dirs
-    Just (psrcLoc, psrcRelFile) -> do
-      let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile
-          psrcFile = psrcLoc </> psrcRelFile
-          pp =
-            fromMaybe
-              (error "Distribution.Simple.PreProcess: Just expected")
-              (lookup (Suffix $ safeTail ext) handlers)
-      -- Preprocessing files for 'sdist' is different from preprocessing
-      -- for 'build'.  When preprocessing for sdist we preprocess to
-      -- avoid that the user has to have the preprocessors available.
-      -- ATM, we don't have a way to specify which files are to be
-      -- preprocessed and which not, so for sdist we only process
-      -- platform independent files and put them into the 'buildLoc'
-      -- (which we assume is set to the temp. directory that will become
-      -- the tarball).
-      -- TODO: eliminate sdist variant, just supply different handlers
-      when (not forSDist || forSDist && platformIndependent pp) $ do
-        -- look for existing pre-processed source file in the dest dir to
-        -- see if we really have to re-run the preprocessor.
-        ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile
-        recomp <- case ppsrcFiles of
-          Nothing -> return True
-          Just ppsrcFile ->
-            i psrcFile `moreRecentFile` i ppsrcFile
-        when recomp $ do
-          let destDir = i buildLoc </> takeDirectory srcStem
-          createDirectoryIfMissingVerbose verbosity True destDir
-          runPreProcessorWithHsBootHack
-            pp
-            (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)
-            (getSymbolicPath $ buildLoc, srcStem <.> "hs")
+      -- look for files in the various source dirs with this module name
+      -- and a file extension of a known preprocessor
+      psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile
+      case psrcFiles of
+        -- no preprocessor file exists, look for an ordinary source file
+        -- just to make sure one actually exists at all for this module.
+
+        -- Note [Dodgy build dirs for preprocessors]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- By looking in the target/output build dir too, we allow
+        -- source files to appear magically in the target build dir without
+        -- any corresponding "real" source file. This lets custom Setup.hs
+        -- files generate source modules directly into the build dir without
+        -- the rest of the build system being aware of it (somewhat dodgy)
+        Nothing ->
+          when failOnMissing $ do
+            dieWithException verbosity $
+              CantFindSourceForPreProcessFile $
+                "can't find source for "
+                  ++ getSymbolicPath baseFile
+                  ++ " in "
+                  ++ intercalate ", " (map getSymbolicPath searchLoc)
+        Just (psrcLoc, psrcRelFile) -> do
+          let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile
+              psrcFile = psrcLoc </> psrcRelFile
+              pp =
+                fromMaybe
+                  (error "Distribution.Simple.PreProcess: Just expected")
+                  (lookup (Suffix $ safeTail ext) handlers)
+          -- Preprocessing files for 'sdist' is different from preprocessing
+          -- for 'build'.  When preprocessing for sdist we preprocess to
+          -- avoid that the user has to have the preprocessors available.
+          -- ATM, we don't have a way to specify which files are to be
+          -- preprocessed and which not, so for sdist we only process
+          -- platform independent files and put them into the 'buildLoc'
+          -- (which we assume is set to the temp. directory that will become
+          -- the tarball).
+          -- TODO: eliminate sdist variant, just supply different handlers
+          when (not forSDist || forSDist && platformIndependent pp) $ do
+            -- look for existing pre-processed source file in the dest dir to
+            -- see if we really have to re-run the preprocessor.
+            ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile
+            recomp <- case ppsrcFiles of
+              Nothing -> return True
+              Just ppsrcFile ->
+                i psrcFile `moreRecentFile` i ppsrcFile
+            when recomp $ do
+              let destDir = i buildLoc </> takeDirectory srcStem
+              createDirectoryIfMissingVerbose verbosity True destDir
+              runPreProcessorWithHsBootHack
+                pp
+                (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)
+                (getSymbolicPath $ buildLoc, srcStem <.> "hs")
+
   where
     i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
     buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)