From 7c9e0de9a1200f8663bd1ea87d5d82a770b4eee7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 08:07:29 -0700 Subject: [PATCH 01/11] Delete second checkPackageDescription call --- Cabal/src/Distribution/PackageDescription/Check.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 8bab6ec961a..eb0cb3fa7b1 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -268,8 +268,6 @@ checkGenericPackageDescription checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes) - -- PackageDescription checks. - checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ From 70ae606ee9dff530a1635a135813536a49a222dd Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 09:54:50 -0700 Subject: [PATCH 02/11] Don't Glob if Glob Ain't Glob 2: The Globbening --- Cabal/src/Distribution/Simple/Glob.hs | 32 ++++++++++++++++++++------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 8798d7a8578..6771f1abd56 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/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,34 @@ 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 = root joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal: " ++ filepath + exist <- doesFileExist 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' From c067f3a8ce38e8e082f90bfc25c952ba8c4d5b6c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 10:05:36 -0700 Subject: [PATCH 03/11] make style --- Cabal/src/Distribution/Simple/Glob.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 6771f1abd56..2d1404bc870 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -439,7 +439,6 @@ runDirFileGlob verbosity mspec rawRoot pat = do if exist then [GlobMatch filepath] else [] - Right variablePattern -> do debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." directoryExists <- doesDirectoryExist (root joinedPrefix) From 1592c519c5d1ec5a0c5c56f7aba2c9dd48a487f2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 10:33:28 -0700 Subject: [PATCH 04/11] Fix tests --- .../UnitTests/Distribution/Simple/Glob.hs | 4 ++-- Cabal/src/Distribution/Simple/Glob.hs | 18 +++++++++++------- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index fce1ffbc050..c07fbb38623 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/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 = diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 2d1404bc870..d15c4a0dfff 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -432,13 +432,17 @@ runDirFileGlob verbosity mspec rawRoot pat = do case pathOrVariablePattern of Left filename -> do - let filepath = root joinedPrefix filename - debug verbosity $ "Treating glob as filepath literal: " ++ filepath - exist <- doesFileExist filepath - pure $ - if exist - then [GlobMatch filepath] - else [] + 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) From 6684a7aa3f53b3dd559090b6637cd116aa5a7a4c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 11:15:55 -0700 Subject: [PATCH 05/11] Avoid redundant glob checking --- .../Distribution/PackageDescription/Check.hs | 88 +++++++++---------- .../PackageDescription/Check/Monad.hs | 1 + 2 files changed, 43 insertions(+), 46 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 8bab6ec961a..f3e425a1e85 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/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) @@ -465,20 +464,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 +502,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 +843,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 +873,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) where dirCheck | all (not . withoutNoMatchesWarning) rs = - [PackageDistSuspiciousWarn $ GlobNoMatch title fp] + [PackageDistSuspiciousWarn $ GlobNoMatch title (show fp)] | otherwise = [] -- If there's a missing directory in play, since globs in Cabal packages @@ -895,9 +892,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 (show fp) file) getWarning (GlobMissingDirectory dir) = - Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) + Just $ PackageDistSuspiciousWarn (GlobNoDir title (show fp) dir) -- GlobMatchesDirectory is handled elsewhere if relevant; -- we can discard it here. getWarning (GlobMatchesDirectory _) = Nothing @@ -999,10 +996,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 +1015,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) diff --git a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs index 23d37570800..0ca3359597c 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Monad.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Monad.hs @@ -37,6 +37,7 @@ module Distribution.PackageDescription.Check.Monad , checkP , checkPkg , liftInt + , liftCM , tellP , checkSpecVer ) where From da080d1a235bd0d5481ab8d629adef122e31314b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 4 Nov 2024 11:23:43 -0700 Subject: [PATCH 06/11] prettyShow --- Cabal/src/Distribution/PackageDescription/Check.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index f3e425a1e85..b9b4dcd7eec 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -873,7 +873,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) where dirCheck | all (not . withoutNoMatchesWarning) rs = - [PackageDistSuspiciousWarn $ GlobNoMatch title (show fp)] + [PackageDistSuspiciousWarn $ GlobNoMatch title (prettyShow fp)] | otherwise = [] -- If there's a missing directory in play, since globs in Cabal packages @@ -892,9 +892,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 (show fp) file) + Just $ PackageDistSuspiciousWarn (GlobExactMatch title (prettyShow fp) file) getWarning (GlobMissingDirectory dir) = - Just $ PackageDistSuspiciousWarn (GlobNoDir title (show fp) dir) + Just $ PackageDistSuspiciousWarn (GlobNoDir title (prettyShow fp) dir) -- GlobMatchesDirectory is handled elsewhere if relevant; -- we can discard it here. getWarning (GlobMatchesDirectory _) = Nothing From 4cb674e4853cd90d986048b2d5067a4c6e8850d5 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 6 Nov 2024 15:49:02 -0700 Subject: [PATCH 07/11] Improve preprocessing performance --- Cabal/src/Distribution/Simple/Build.hs | 8 +- Cabal/src/Distribution/Simple/PreProcess.hs | 141 +++++++++++--------- 2 files changed, 86 insertions(+), 63 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index e153c25b9d7..fcf113eb81f 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -614,8 +614,11 @@ generateCode -> Verbosity -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) generateCode codeGens nm pdesc bi lbi clbi verbosity = do + debug verbosity $ "generateCode: " <> prettyShow (package pdesc) when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir - (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + ret <- (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + debug verbosity "generateCode complete" + pure ret where allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi @@ -625,7 +628,8 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") go :: String -> IO [ModuleName.ModuleName] - go codeGenProg = + go codeGenProg = do + debug verbosity $ "Performing codegen: " <> codeGenProg fmap fromString . lines <$> getDbProgramOutputCwd verbosity diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index e56627893c1..34927a09af6 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -51,11 +51,13 @@ import Distribution.Compat.Prelude import Distribution.Compat.Stack import Prelude () +import Control.Concurrent.Async import Distribution.Backpack.DescribeUnitId import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.CCompiler import Distribution.Simple.Compiler @@ -159,14 +161,16 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = (Nothing :: Maybe [(ModuleName, Module)]) case comp of (CLib lib@Library{libBuildInfo = bi}) -> do + debug verbosity $ "Preprocessing library: " <> show (libName lib) let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) - for_ (map moduleNameSymbolicPath mods) $ + for_ $ pre dirs (componentBuildDir lbi clbi) hndlrs (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do + debug verbosity $ "Preprocessing foreign library: " <> prettyShow (foreignLibName flib) let flibDir = flibBuildDir lbi flib dirs = hsSourceDirs bi @@ -186,6 +190,7 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = ] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + debug verbosity $ "Module count: " <> show (length mods) for_ (map moduleNameSymbolicPath mods) $ pre dirs exeDir hndlrs pre (hsSourceDirs bi) exeDir (localHandlers bi) $ @@ -208,8 +213,11 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = BenchmarkUnsupported tt -> dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt where - orderingFromHandlers v d hndlrs mods = - foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs + orderingFromHandlers v d hndlrs mods = do + debug v $ " orderingFromHandlers begin" + a <- foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs + debug v $ " orderingFromHandlers end" + pure a builtinCSuffixes = map Suffix cSourceExtensions builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] @@ -292,10 +300,11 @@ preprocessFile -- ^ fail on missing file -> IO () preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do + debug verbosity $ "preprocessFile: " <> prettyShow baseFile + bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile -- 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 + case bsrcFiles of -- no preprocessor file exists, look for an ordinary source file -- just to make sure one actually exists at all for this module. @@ -307,48 +316,56 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- files generate source modules directly into the build dir without -- the rest of the build system being aware of it (somewhat dodgy) 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") + psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile + case psrcFiles of + Nothing -> + when failOnMissing $ do + dieWithException verbosity $ + CantFindSourceForPreProcessFile $ + "can't find source for " + ++ getSymbolicPath baseFile + ++ " in " + ++ intercalate ", " (map getSymbolicPath searchLoc) + + Just (psrcLoc, psrcRelFile) -> do + debug verbosity $ " Found pre-processable file: " <> prettyShow psrcLoc + 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 + debug verbosity " Searching for existing pre-processed source file" + -- 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 + debug verbosity " Preprocessing file. . ." + let destDir = i buildLoc takeDirectory srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + pp + (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile) + (getSymbolicPath $ buildLoc, srcStem <.> "hs") + debug verbosity $ "Preprocessing file complete: " <> prettyShow baseFile + + -- found a non-processable file in one of the source dirs + Just _ -> do + pure () where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) @@ -897,20 +914,22 @@ preprocessExtras -> Component -> LocalBuildInfo -> IO [SymbolicPath Pkg File] -preprocessExtras verbosity comp lbi = case comp of - CLib _ -> pp $ buildDir lbi - (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe - (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib - CTest test -> - case testInterface test of - TestSuiteUnsupported tt -> - dieWithException verbosity $ NoSupportPreProcessingTestExtras tt - _ -> pp $ testBuildDir lbi test - CBench bm -> - case benchmarkInterface bm of - BenchmarkUnsupported tt -> - dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt - _ -> pp $ benchmarkBuildDir lbi bm +preprocessExtras verbosity comp lbi = do + debug verbosity $ "in preprocessExtras" + case comp of + CLib _ -> pp $ buildDir lbi + (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe + (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib + CTest test -> + case testInterface test of + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingTestExtras tt + _ -> pp $ testBuildDir lbi test + CBench bm -> + case benchmarkInterface bm of + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt + _ -> pp $ benchmarkBuildDir lbi bm where pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File] pp builddir = do From e7f4251b301b711a079b27fdeddb8d6abb9b57b8 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 6 Nov 2024 15:55:05 -0700 Subject: [PATCH 08/11] whoops --- Cabal/src/Distribution/Simple/PreProcess.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 34927a09af6..2f93a04b235 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -51,7 +51,6 @@ import Distribution.Compat.Prelude import Distribution.Compat.Stack import Prelude () -import Control.Concurrent.Async import Distribution.Backpack.DescribeUnitId import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName (ModuleName) @@ -167,7 +166,7 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) - for_ $ + for_ (map moduleNameSymbolicPath mods) $ pre dirs (componentBuildDir lbi clbi) hndlrs (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do debug verbosity $ "Preprocessing foreign library: " <> prettyShow (foreignLibName flib) @@ -326,7 +325,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS ++ getSymbolicPath baseFile ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) - Just (psrcLoc, psrcRelFile) -> do debug verbosity $ " Found pre-processable file: " <> prettyShow psrcLoc let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile From 354f1b015595b2dd69fdb59246fd8ad72b3a8b22 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 22 Nov 2024 14:52:30 -0700 Subject: [PATCH 09/11] Remove debugs --- Cabal/src/Distribution/Simple/Build.hs | 8 ++------ Cabal/src/Distribution/Simple/PreProcess.hs | 20 +++----------------- 2 files changed, 5 insertions(+), 23 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index fcf113eb81f..e153c25b9d7 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -614,11 +614,8 @@ generateCode -> Verbosity -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) generateCode codeGens nm pdesc bi lbi clbi verbosity = do - debug verbosity $ "generateCode: " <> prettyShow (package pdesc) when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir - ret <- (\x -> (tgtDir, x)) . concat <$> mapM go codeGens - debug verbosity "generateCode complete" - pure ret + (\x -> (tgtDir, x)) . concat <$> mapM go codeGens where allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi @@ -628,8 +625,7 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") go :: String -> IO [ModuleName.ModuleName] - go codeGenProg = do - debug verbosity $ "Performing codegen: " <> codeGenProg + go codeGenProg = fmap fromString . lines <$> getDbProgramOutputCwd verbosity diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 2f93a04b235..acee46bfa9c 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -56,7 +56,6 @@ import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription as PD -import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.CCompiler import Distribution.Simple.Compiler @@ -160,7 +159,6 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = (Nothing :: Maybe [(ModuleName, Module)]) case comp of (CLib lib@Library{libBuildInfo = bi}) -> do - debug verbosity $ "Preprocessing library: " <> show (libName lib) let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] @@ -169,7 +167,6 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = for_ (map moduleNameSymbolicPath mods) $ pre dirs (componentBuildDir lbi clbi) hndlrs (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do - debug verbosity $ "Preprocessing foreign library: " <> prettyShow (foreignLibName flib) let flibDir = flibBuildDir lbi flib dirs = hsSourceDirs bi @@ -189,7 +186,6 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = ] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) - debug verbosity $ "Module count: " <> show (length mods) for_ (map moduleNameSymbolicPath mods) $ pre dirs exeDir hndlrs pre (hsSourceDirs bi) exeDir (localHandlers bi) $ @@ -212,11 +208,8 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = BenchmarkUnsupported tt -> dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt where - orderingFromHandlers v d hndlrs mods = do - debug v $ " orderingFromHandlers begin" - a <- foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs - debug v $ " orderingFromHandlers end" - pure a + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs builtinCSuffixes = map Suffix cSourceExtensions builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] @@ -299,7 +292,6 @@ preprocessFile -- ^ fail on missing file -> IO () preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do - debug verbosity $ "preprocessFile: " <> prettyShow baseFile bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor @@ -326,7 +318,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) Just (psrcLoc, psrcRelFile) -> do - debug verbosity $ " Found pre-processable file: " <> prettyShow psrcLoc let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile psrcFile = psrcLoc psrcRelFile pp = @@ -343,7 +334,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- the tarball). -- TODO: eliminate sdist variant, just supply different handlers when (not forSDist || forSDist && platformIndependent pp) $ do - debug verbosity " Searching for existing pre-processed source file" -- 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 @@ -352,14 +342,12 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS Just ppsrcFile -> i psrcFile `moreRecentFile` i ppsrcFile when recomp $ do - debug verbosity " Preprocessing file. . ." let destDir = i buildLoc takeDirectory srcStem createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile) (getSymbolicPath $ buildLoc, srcStem <.> "hs") - debug verbosity $ "Preprocessing file complete: " <> prettyShow baseFile -- found a non-processable file in one of the source dirs Just _ -> do @@ -912,9 +900,7 @@ preprocessExtras -> Component -> LocalBuildInfo -> IO [SymbolicPath Pkg File] -preprocessExtras verbosity comp lbi = do - debug verbosity $ "in preprocessExtras" - case comp of +preprocessExtras verbosity comp lbi = case comp of CLib _ -> pp $ buildDir lbi (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib From 4e00e208d1008a8b19a19a8224d4d95aa3461847 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 22 Nov 2024 14:53:31 -0700 Subject: [PATCH 10/11] style --- Cabal/src/Distribution/Simple/PreProcess.hs | 26 ++++++++++----------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index acee46bfa9c..9a8903ed985 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -901,19 +901,19 @@ preprocessExtras -> LocalBuildInfo -> IO [SymbolicPath Pkg File] preprocessExtras verbosity comp lbi = case comp of - CLib _ -> pp $ buildDir lbi - (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe - (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib - CTest test -> - case testInterface test of - TestSuiteUnsupported tt -> - dieWithException verbosity $ NoSupportPreProcessingTestExtras tt - _ -> pp $ testBuildDir lbi test - CBench bm -> - case benchmarkInterface bm of - BenchmarkUnsupported tt -> - dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt - _ -> pp $ benchmarkBuildDir lbi bm + CLib _ -> pp $ buildDir lbi + (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe + (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib + CTest test -> + case testInterface test of + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingTestExtras tt + _ -> pp $ testBuildDir lbi test + CBench bm -> + case benchmarkInterface bm of + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt + _ -> pp $ benchmarkBuildDir lbi bm where pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File] pp builddir = do From dfc1d354b8923e4a22757fc2eb0ea48ce8cb5aa9 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 22 Nov 2024 15:39:07 -0700 Subject: [PATCH 11/11] Cleaner organization, relocated comments --- Cabal/src/Distribution/Simple/PreProcess.hs | 30 ++++++++++----------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 9a8903ed985..7cd1e21a584 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -293,22 +293,25 @@ preprocessFile -> IO () preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor case bsrcFiles 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) + -- found a non-processable file in one of the source dirs + Just _ -> do + pure () Nothing -> 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) Nothing -> when failOnMissing $ do dieWithException verbosity $ @@ -349,9 +352,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile) (getSymbolicPath $ buildLoc, srcStem <.> "hs") - -- found a non-processable file in one of the source dirs - Just _ -> do - pure () where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)