Add Legacy Comparison Flag

cabal-install/cabal-install.cabal

@@ -44,6 +44,11 @@ flag git-rev
   default: False
   manual: True
 
+flag legacy-comparison
+  description: Enable comparison between the new and legacy cabal.project parser
+  default: False
+  manual: True
+
 common warnings
     ghc-options:
       -Wall
@@ -282,6 +287,9 @@ library
       build-depends: githash ^>= 0.1.7.0
       cpp-options: -DGIT_REV
 
+    if flag(legacy-comparison)
+      cpp-options: -DLEGACY_COMPARISON
+
 executable cabal
     import: warnings, base-dep
     main-is: Main.hs

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 -- | Handling project configuration.
 module Distribution.Client.ProjectConfig
@@ -117,7 +118,9 @@ import Distribution.Client.HttpUtils
   )
 import Distribution.Client.Types
 import Distribution.Client.Utils.Parsec (renderParseError)
+#ifdef LEGACY_COMPARISON
 import GHC.Stack (HasCallStack, callStack)
+#endif
 
 import Distribution.Simple.Errors
 import Distribution.Simple.PackageDescription (flattenDups)
@@ -830,30 +833,46 @@ readProjectLocalFreezeConfig verbosity httpTransport distDirLayout =
     "freeze"
     "project freeze file"
 
+{- HLINT ignore "Defined but not used" -}
+
 -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
+#ifdef LEGACY_COMPARISON
 readProjectFileSkeleton :: HasCallStack => Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
+#else
+readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
+#endif
 readProjectFileSkeleton
   verbosity
   httpTransport
-  dir@DistDirLayout{distProjectFile, distDownloadSrcDirectory}
+  dir
   extensionName
-  extensionDescription = do
-    legacyPcs <- readProjectFileSkeletonLegacy verbosity httpTransport dir extensionName extensionDescription
-    exists <- liftIO $ doesFileExist extensionFile
-    if exists
-      then do
-        monitorFiles [monitorFileHashed extensionFile]
+  extensionDescription =
+    do
+      exists <- liftIO $ doesFileExist extensionFile
+      if exists
+        then do
+          monitorFiles [monitorFileHashed extensionFile]
+          parseConfig
+        else do
+          monitorFiles [monitorNonExistentFile extensionFile]
+          return mempty
+    where
+      extensionFile = (distProjectFile dir) extensionName
+      readExtensionFile :: Verbosity -> FilePath -> IO ProjectConfigSkeleton
+      readExtensionFile verbosity' file = readAndParseFile (Parsec.parseProject extensionFile (distDownloadSrcDirectory dir) httpTransport verbosity' . ProjectConfigToParse) verbosity' file
+#ifdef LEGACY_COMPARISON
+      parseConfig = do
+        legacyPcs <- readProjectFileSkeletonLegacy verbosity httpTransport dir extensionName extensionDescription
         pcs <- liftIO $ readExtensionFile verbosity extensionFile
         monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs)
         unless (legacyPcs == pcs) (error (show callStack ++ "\nParsec: " ++ show pcs ++ "\nLegacy: " ++ show legacyPcs))
-        pure pcs
-      else do
-        monitorFiles [monitorNonExistentFile extensionFile]
-        return mempty
-    where
-      extensionFile = distProjectFile extensionName
-      readExtensionFile :: Verbosity -> FilePath -> IO ProjectConfigSkeleton
-      readExtensionFile verbosity' file = readAndParseFile (Parsec.parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity' . ProjectConfigToParse) verbosity' file
+        return pcs
+#else
+      parseConfig = do
+        pcs <- liftIO $ readExtensionFile verbosity extensionFile
+        monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs)
+        return pcs
+#endif
 
 readAndParseFile
   :: (BS.ByteString -> IO (Parsec.ParseResult a))