Fix SourceRepoParser, Add Expectations (#6101)

Author: jgotoh

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

@@ -13,14 +13,15 @@ module Distribution.Client.ProjectConfig.Parsec (
   runParseResult
   ) where
 
-import Control.Monad.State.Strict                    (StateT, execStateT, lift)
+import Control.Monad.State.Strict                    (StateT, execStateT, lift, modify)
 import Distribution.CabalSpecVersion
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Distribution.FieldGrammar
 -- TODO #6101 .Legacy -> ProjectConfigSkeleton should probably be moved here
 import Distribution.Client.ProjectConfig.FieldGrammar (projectConfigFieldGrammar)
 import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton, ProjectConfigImport)
+import qualified Distribution.Client.ProjectConfig.Lens as L
 import Distribution.Client.ProjectConfig.Types (ProjectConfig (..))
 import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
 import Distribution.Fields.ConfVar                   (parseConditionConfVar)
@@ -69,25 +70,27 @@ parseProjectSkeleton' lexWarnings utf8WarnPos fs = do
     parseCondTree fs
 
 -- List of conditional blocks
-newtype Conditionals = Conditionals [[Section Position]]
+newtype Conditional ann = Conditional [Section ann]
+  deriving (Eq, Show)
 
--- | Separate conditional blocks from other sections so
+-- | Separate valid conditional blocks from other sections so
 -- all conditionals form their own groups.
-partitionConditionals :: [[Section Position]] -> ([[Section Position]], Conditionals)
-partitionConditionals sections = undefined
+-- TODO implement
+partitionConditionals :: [[Section ann]] -> ([Section ann], [Conditional ann])
+partitionConditionals sections = (concat sections, [])
 
 parseCondTree
     :: [Field Position]
     -> ParseResult ProjectConfigSkeleton
 parseCondTree fields0 = do
     -- sections are groups of sections between fields
-    let (fs, sections) = partitionFields fields0
-        (sectionGroups, conditionals) = partitionConditionals sections
+    let (fs, sectionGroups) = partitionFields fields0
+        (sections, conditionals) = partitionConditionals sectionGroups
         msg = show sectionGroups
     imports <- parseImports fs
     config <- parseFieldGrammar cabalSpecLatest fs projectConfigFieldGrammar
-    config' <- view stateConfig <$> execStateT (goSections sectionGroups) (SectionS config)
-    let configSkeleton = CondNode config imports []
+    config' <- view stateConfig <$> execStateT (goSections sections) (SectionS config)
+    let configSkeleton = CondNode config' imports []
     -- TODO parse conditionals
     return configSkeleton
 
@@ -103,17 +106,15 @@ stateConfig :: Lens' SectionS ProjectConfig
 stateConfig f (SectionS cfg) = SectionS <$> f cfg
 {-# INLINEABLE stateConfig #-}
 
-goSections :: [[Section Position]] -> SectionParser ()
-goSections = traverse_ parseSectionGroup
-
-parseSectionGroup :: [Section Position] -> SectionParser ()
-parseSectionGroup = traverse_ parseSection
+goSections :: [Section Position] -> SectionParser ()
+goSections = traverse_ parseSection
 
 parseSection :: Section Position -> SectionParser ()
 parseSection (MkSection (Name pos name) args secFields)
     | name == "source-repository-package" = do
         let (fields, secs) = partitionFields secFields
         srp <- lift $ parseFieldGrammar cabalSpecLatest fields sourceRepositoryPackageGrammar
+        stateConfig . L.projectPackagesRepo %= (++ [srp])
         unless (null secs) (warnInvalidSubsection pos name)
     | otherwise = do
         warnInvalidSubsection pos name

cabal-install/tests/IntegrationTests2/ProjectConfig/ParsecTests.hs

@@ -1,58 +1,37 @@
 -- | Integration Tests related to parsing of ProjectConfigs
-
 module IntegrationTests2.ProjectConfig.ParsecTests (parserTests) where
 
-import qualified Data.ByteString       as BS
-import System.Directory
-import System.FilePath
-import Test.Tasty
-import Test.Tasty.HUnit
-import Test.Tasty.Options
-
-import Distribution.Client.HttpUtils
+import qualified Data.ByteString as BS
 import Distribution.Client.DistDirLayout
+import Distribution.Client.HttpUtils
 import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectConfig.Parsec
 import Distribution.Client.RebuildMonad (runRebuild)
+import Distribution.Client.Types.SourceRepo
 import Distribution.Types.CondTree (CondTree (..))
 import Distribution.Types.PackageName
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))
+import Distribution.Types.SourceRepo (KnownRepoType (..), RepoType (..))
 import Distribution.Types.Version (Version, mkVersion)
 import Distribution.Types.VersionRange.Internal (VersionRange (..))
 import Distribution.Verbosity
+import System.Directory
+import System.FilePath
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.Options
 
 -- TODO create tests:
 -- - parser tests to read and compare to expected values
 -- - golden tests for warnings and errors
 parserTests :: [TestTree]
-parserTests = [
-  -- testCase "read with legacy parser" testLegacyRead
-  testCase "read packages" testPackages
-  , testCase "read optional-packages" testOptionalPackages
-  , testCase "read extra-packages" testExtraPackages
-  , testCase "read source-repository-package" testSourceRepoList
+parserTests =
+  [ testCase "read packages" testPackages,
+    testCase "read optional-packages" testOptionalPackages,
+    testCase "read extra-packages" testExtraPackages,
+    testCase "read source-repository-package" testSourceRepoList
   ]
 
-testLegacyRead :: Assertion
-testLegacyRead = do
-  httpTransport <- configureTransport verbosity [] Nothing
-  projectRootDir <- canonicalizePath basedir
-
-  -- let projectRoot = ProjectRootImplicit projectRootDir
-  let projectFileName = "cabal-minimal.project"
-      projectRoot = ProjectRootExplicit projectRootDir projectFileName
-      extensionName = ""
-      distDirLayout = defaultDistDirLayout projectRoot Nothing
-      extensionDescription = "description"
-      distProjectConfigFp = distProjectFile distDirLayout extensionName
-  print distProjectConfigFp
-  exists <- doesFileExist distProjectConfigFp
-  print $ exists
-  projectConfigSkeletonLegacy <- runRebuild projectRootDir $
-    readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription
-  projectConfigSkeleton <- runRebuild projectRootDir $
-    readProjectFileSkeleton verbosity httpTransport distDirLayout extensionName extensionDescription
-  projectConfigSkeleton @?= projectConfigSkeletonLegacy
-
 testPackages :: Assertion
 testPackages = do
   let expected = [".", "packages/packages.cabal"] -- TODO also test https link
@@ -69,23 +48,41 @@ testOptionalPackages = do
 
 testSourceRepoList :: Assertion
 testSourceRepoList = do
-  let expected = [
-                 ]
+  let expected =
+        [ SourceRepositoryPackage
+            { srpType = KnownRepoType Git,
+              srpLocation = "https://example.com/Project.git",
+              srpTag = Just "1234",
+              srpBranch = Nothing,
+              srpSubdir = [],
+              srpCommand = []
+            },
+          SourceRepositoryPackage
+            { srpType = KnownRepoType Git,
+              srpLocation = "https://example.com/example-dir/",
+              srpTag = Just "12345",
+              srpBranch = Nothing,
+              srpSubdir = ["subproject"],
+              srpCommand = []
+            }
+        ]
   (config, legacy) <- readConfigDefault "source-repository-packages"
   assertConfig expected config legacy (projectPackagesRepo . condTreeData)
 
 testExtraPackages :: Assertion
 testExtraPackages = do
-  let expected = [
-        PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])),
-        PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0,7,3])) (EarlierVersion (mkVersion [0,9])))
-                 ]
+  let expected =
+        [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])),
+          PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9])))
+        ]
   (config, legacy) <- readConfigDefault "extra-packages"
   assertConfig expected config legacy (projectPackagesNamed . condTreeData)
 
 readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
 readConfigDefault rootFp = readConfig rootFp "cabal.project"
 
+-- TODO this is an overkill, look at warningTests, they just use runParseResult without
+-- httpTransport etc
 readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
 readConfig rootFp projectFileName = do
   -- TODO extract argument so it can be mocked
@@ -99,10 +96,12 @@ readConfig rootFp projectFileName = do
       distProjectConfigFp = distProjectFile distDirLayout extensionName
   exists <- doesFileExist distProjectConfigFp
   assertBool ("projectConfig does not exist: " <> distProjectConfigFp) exists
-  parsec <- runRebuild projectRootDir $
-    readProjectFileSkeleton verbosity httpTransport distDirLayout extensionName extensionDescription
-  legacy <- runRebuild projectRootDir $
-    readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription
+  parsec <-
+    runRebuild projectRootDir $
+      readProjectFileSkeleton verbosity httpTransport distDirLayout extensionName extensionDescription
+  legacy <-
+    runRebuild projectRootDir $
+      readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription
   return (parsec, legacy)
 
 assertConfig' :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> IO ()
@@ -123,7 +122,7 @@ emptyProjectConfig :: ProjectConfig
 emptyProjectConfig = mempty
 
 verbosity :: Verbosity
-verbosity = minBound --normal --verbose --maxBound --minBound
+verbosity = normal -- minBound --normal --verbose --maxBound --minBound
 
 basedir :: FilePath
 basedir = "tests" </> "IntegrationTests2" </> "ProjectConfig" </> "files"