From 048dac5af68d2832275b44aa8cc5337fe219b44e Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 26 Jul 2019 00:56:35 +0300
Subject: [PATCH] Resolve #5472: Add SourceRepositoryPackage..

which can be parametrised over container of subdirs: [], Maybe, Proxy...
---
 .../Distribution/Client/Compat/Prelude.hs     |   2 +
 cabal-install/Distribution/Client/Get.hs      |  65 ++++++--
 .../Distribution/Client/HttpUtils.hs          |   2 +-
 .../Distribution/Client/ProjectConfig.hs      |  49 +++---
 .../Client/ProjectConfig/Legacy.hs            |  10 +-
 .../Client/ProjectConfig/Types.hs             |   5 +-
 .../Distribution/Client/ProjectPlanOutput.hs  |  16 +-
 .../Distribution/Client/SourceRepo.hs         |  96 ++++++++++++
 .../Distribution/Client/SourceRepoParse.hs    |  23 ---
 cabal-install/Distribution/Client/Types.hs    |   6 +-
 cabal-install/Distribution/Client/VCS.hs      | 146 ++++++++----------
 cabal-install/cabal-install.cabal             |   2 +-
 cabal-install/cabal-install.cabal.pp          |   2 +-
 .../UnitTests/Distribution/Client/Get.hs      |  26 +++-
 .../Distribution/Client/ProjectConfig.hs      |  53 +++----
 .../Distribution/Client/TreeDiffInstances.hs  |   3 +
 .../UnitTests/Distribution/Client/VCS.hs      |  36 +++--
 17 files changed, 329 insertions(+), 213 deletions(-)
 create mode 100644 cabal-install/Distribution/Client/SourceRepo.hs
 delete mode 100644 cabal-install/Distribution/Client/SourceRepoParse.hs

diff --git a/cabal-install/Distribution/Client/Compat/Prelude.hs b/cabal-install/Distribution/Client/Compat/Prelude.hs
index bac2ad4ff4..bd34f94b8a 100644
--- a/cabal-install/Distribution/Client/Compat/Prelude.hs
+++ b/cabal-install/Distribution/Client/Compat/Prelude.hs
@@ -13,7 +13,9 @@
 module Distribution.Client.Compat.Prelude
   ( module Distribution.Compat.Prelude.Internal
   , Prelude.IO
+  , Proxy (..)
   ) where
 
 import Prelude (IO)
 import Distribution.Compat.Prelude.Internal hiding (IO)
+import Data.Proxy (Proxy (..))
diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs
index 006eb57d66..c70d0e7333 100644
--- a/cabal-install/Distribution/Client/Get.hs
+++ b/cabal-install/Distribution/Client/Get.hs
@@ -24,6 +24,7 @@ module Distribution.Client.Get (
 
 import Prelude ()
 import Distribution.Client.Compat.Prelude hiding (get)
+import Data.Ord (comparing)
 import Distribution.Compat.Directory
          ( listDirectory )
 import Distribution.Package
@@ -38,6 +39,8 @@ import Distribution.Deprecated.Text (display)
 import qualified Distribution.PackageDescription as PD
 import Distribution.Simple.Program
          ( programName )
+import Distribution.Types.SourceRepo (RepoKind (..))
+import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)
 
 import Distribution.Client.Setup
          ( GlobalFlags(..), GetFlags(..), RepoContext(..) )
@@ -114,7 +117,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
           . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
       where
         kind = fromFlag . getSourceRepository $ getFlags
-        packageSourceRepos :: SourcePackage loc -> [SourceRepo]
+        packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
         packageSourceRepos = PD.sourceRepos
                            . PD.packageDescription
                            . packageDescription
@@ -197,11 +200,11 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
 data ClonePackageException =
        ClonePackageNoSourceRepos       PackageId
      | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
-     | ClonePackageNoRepoType          PackageId SourceRepo
-     | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType
-     | ClonePackageNoRepoLocation      PackageId SourceRepo
+     | ClonePackageNoRepoType          PackageId PD.SourceRepo
+     | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
+     | ClonePackageNoRepoLocation      PackageId PD.SourceRepo
      | ClonePackageDestinationExists   PackageId FilePath Bool
-     | ClonePackageFailedWithExitCode  PackageId SourceRepo String ExitCode
+     | ClonePackageFailedWithExitCode  PackageId SourceRepoProxy String ExitCode
   deriving (Show, Eq)
 
 instance Exception ClonePackageException where
@@ -237,7 +240,7 @@ instance Exception ClonePackageException where
   displayException (ClonePackageFailedWithExitCode
                       pkgid repo vcsprogname exitcode) =
        "Failed to fetch the source repository for package " ++ display pkgid
-    ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " ("
+    ++ ", repository location " ++ srpLocation repo ++ " ("
     ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
 
 
@@ -248,7 +251,7 @@ instance Exception ClonePackageException where
 clonePackagesFromSourceRepo :: Verbosity
                             -> FilePath            -- ^ destination dir prefix
                             -> Maybe RepoKind      -- ^ preferred 'RepoKind'
-                            -> [(PackageId, [SourceRepo])]
+                            -> [(PackageId, [PD.SourceRepo])]
                                                    -- ^ the packages and their
                                                    -- available 'SourceRepo's
                             -> IO ()
@@ -268,14 +271,14 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
       [ cloneSourceRepo verbosity vcs' repo destDir
           `catch` \exitcode ->
            throwIO (ClonePackageFailedWithExitCode
-                      pkgid repo (programName (vcsProgram vcs)) exitcode)
+                      pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)
       | (pkgid, repo, vcs, destDir) <- pkgrepos'
       , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
       ]
 
   where
-    preCloneChecks :: (PackageId, [SourceRepo])
-                   -> IO (PackageId, SourceRepo, VCS Program, FilePath)
+    preCloneChecks :: (PackageId, [PD.SourceRepo])
+                   -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
     preCloneChecks (pkgid, repos) = do
       repo <- case selectPackageSourceRepo preferredRepoKind repos of
         Just repo            -> return repo
@@ -283,13 +286,13 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
         Nothing              -> throwIO (ClonePackageNoSourceReposOfKind
                                            pkgid preferredRepoKind)
 
-      vcs <- case validateSourceRepo repo of
-        Right (_, _, _, vcs) -> return vcs
+      (repo', vcs) <- case validatePDSourceRepo repo of
+        Right (repo', _, _, vcs) -> return (repo', vcs)
         Left SourceRepoRepoTypeUnspecified ->
           throwIO (ClonePackageNoRepoType pkgid repo)
 
-        Left (SourceRepoRepoTypeUnsupported repoType) ->
-          throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType)
+        Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
+          throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
 
         Left SourceRepoLocationUnspecified ->
           throwIO (ClonePackageNoRepoLocation pkgid repo)
@@ -300,5 +303,37 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
       when (destDirExists || destFileExists) $
         throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
 
-      return (pkgid, repo, vcs, destDir)
+      return (pkgid, repo', vcs, destDir)
 
+-------------------------------------------------------------------------------
+-- Selecting
+-------------------------------------------------------------------------------
+
+-- | Pick the 'SourceRepo' to use to get the package sources from.
+--
+-- Note that this does /not/ depend on what 'VCS' drivers we are able to
+-- successfully configure. It is based only on the 'SourceRepo's declared
+-- in the package, and optionally on a preferred 'RepoKind'.
+--
+selectPackageSourceRepo :: Maybe RepoKind
+                        -> [PD.SourceRepo]
+                        -> Maybe PD.SourceRepo
+selectPackageSourceRepo preferredRepoKind =
+    listToMaybe
+    -- Sort repositories by kind, from This to Head to Unknown. Repositories
+    -- with equivalent kinds are selected based on the order they appear in
+    -- the Cabal description file.
+  . sortBy (comparing thisFirst)
+    -- If the user has specified the repo kind, filter out the repositories
+    -- they're not interested in.
+  . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
+  where
+    thisFirst :: PD.SourceRepo -> Int
+    thisFirst r = case PD.repoKind r of
+        RepoThis -> 0
+        RepoHead -> case PD.repoTag r of
+            -- If the type is 'head' but the author specified a tag, they
+            -- probably meant to create a 'this' repository but screwed up.
+            Just _  -> 0
+            Nothing -> 1
+        RepoKindUnknown _ -> 2
diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs
index 1fd8ae86b2..4cd823f102 100644
--- a/cabal-install/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/Distribution/Client/HttpUtils.hs
@@ -15,7 +15,7 @@ module Distribution.Client.HttpUtils (
   ) where
 
 import Prelude ()
-import Distribution.Client.Compat.Prelude
+import Distribution.Client.Compat.Prelude hiding (Proxy (..))
 
 import Network.HTTP
          ( Request (..), Response (..), RequestMethod (..)
diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs
index 23e3cd987e..5c231e9039 100644
--- a/cabal-install/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/Distribution/Client/ProjectConfig.hs
@@ -100,7 +100,9 @@ import Distribution.Fields
          ( runParseResult, PError, PWarning, showPWarning)
 import Distribution.Pretty ()
 import Distribution.Types.SourceRepo
-         ( SourceRepo(..), RepoType(..), )
+         ( RepoType(..) )
+import Distribution.Client.SourceRepo
+         ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )
 import Distribution.Simple.Compiler
          ( Compiler, compilerInfo )
 import Distribution.Simple.Program
@@ -139,6 +141,7 @@ import Data.Either
 import qualified Data.ByteString       as BS
 import qualified Data.ByteString.Lazy  as LBS
 import qualified Data.Map as Map
+import qualified Data.List.NonEmpty as NE
 import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Hashable as Hashable
@@ -647,7 +650,7 @@ data ProjectPackageLocation =
    | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
    | ProjectPackageLocalTarball   FilePath
    | ProjectPackageRemoteTarball  URI
-   | ProjectPackageRemoteRepo     SourceRepo
+   | ProjectPackageRemoteRepo     SourceRepoList
    | ProjectPackageNamed          PackageVersionConstraint
   deriving Show
 
@@ -1108,7 +1111,7 @@ syncAndReadSourcePackagesRemoteRepos
   :: Verbosity
   -> DistDirLayout
   -> ProjectConfigShared
-  -> [SourceRepo]
+  -> [SourceRepoList]
   -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
 syncAndReadSourcePackagesRemoteRepos verbosity
                                      DistDirLayout{distDownloadSrcDirectory}
@@ -1123,7 +1126,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
     -- All 'SourceRepo's grouped by referring to the "same" remote repo
     -- instance. So same location but can differ in commit/tag/branch/subdir.
     let reposByLocation :: Map (RepoType, String)
-                               [(SourceRepo, RepoType)]
+                               [(SourceRepoList, RepoType)]
         reposByLocation = Map.fromListWith (++)
                             [ ((rtype, rloc), [(repo, vcsRepoType vcs)])
                             | (repo, rloc, rtype, vcs) <- repos' ]
@@ -1143,7 +1146,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
             pathStem = distDownloadSrcDirectory
                    </> localFileNameForRemoteRepo primaryRepo
             monitor :: FileMonitor
-                         [SourceRepo]
+                         [SourceRepoList]
                          [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
             monitor  = newFileMonitor (pathStem <.> "cache")
       ]
@@ -1151,7 +1154,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
     syncRepoGroupAndReadSourcePackages
       :: VCS ConfiguredProgram
       -> FilePath
-      -> [SourceRepo]
+      -> [SourceRepoList]
       -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
     syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do
         liftIO $ createDirectoryIfMissingVerbose verbosity False
@@ -1168,24 +1171,33 @@ syncAndReadSourcePackagesRemoteRepos verbosity
         sequence
           [ readPackageFromSourceRepo repoWithSubdir repoPath
           | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths
-          , repoWithSubdir <- reposWithSubdir ]
+          , repoWithSubdir <- NE.toList reposWithSubdir ]
       where
         -- So to do both things above, we pair them up here.
+        repoGroupWithPaths
+          :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
         repoGroupWithPaths =
           zipWith (\(x, y) z -> (x,y,z))
-                  (Map.toList
-                    (Map.fromListWith (++)
-                      [ (repo { repoSubdir = Nothing }, [repo])
-                      | repo <- repoGroup ]))
+                  (mapGroup
+                      [ (repo { srpSubdir = Proxy }, repo)
+                      | repo <- foldMap (NE.toList . srpFanOut) repoGroup
+                      ])
                   repoPaths
 
+        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
+        mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))
+
         -- The repos in a group are given distinct names by simple enumeration
         -- foo, foo-2, foo-3 etc
+        repoPaths :: [FilePath]
         repoPaths = pathStem
                   : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]
 
+    readPackageFromSourceRepo
+        :: SourceRepositoryPackage Maybe -> FilePath
+        -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
     readPackageFromSourceRepo repo repoPath = do
-        let packageDir = maybe repoPath (repoPath </>) (repoSubdir repo)
+        let packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
         entries <- liftIO $ getDirectoryContents packageDir
         --TODO: wrap exceptions
         case filter (\e -> takeExtension e == ".cabal") entries of
@@ -1201,10 +1213,10 @@ syncAndReadSourcePackagesRemoteRepos verbosity
               location      = RemoteSourceRepoPackage repo packageDir
 
 
-    reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a
+    reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
     reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems
 
-    renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String
+    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
     renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"
 
 
@@ -1357,10 +1369,9 @@ localFileNameForRemoteTarball uri =
 -- This is deterministic based on the source repo identity details, and
 -- intended to produce non-clashing file names for different repos.
 --
-localFileNameForRemoteRepo :: SourceRepo -> FilePath
-localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} =
-    maybe "" ((++ "-") . mangleName) repoLocation
- ++ showHex locationHash ""
+localFileNameForRemoteRepo :: SourceRepoList -> FilePath
+localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =
+    mangleName srpLocation ++ "-" ++ showHex locationHash ""
   where
     mangleName = truncateString 10 . dropExtension
                . takeFileName . dropTrailingPathSeparator
@@ -1368,7 +1379,7 @@ localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} =
     -- just the parts that make up the "identity" of the repo
     locationHash :: Word
     locationHash =
-      fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule))
+      fromIntegral (Hashable.hash (show srpType, srpLocation))
 
 
 -- | Truncate a string, with a visual indication that it is truncated.
diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
index 1904d51be9..b1738ffd75 100644
--- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
@@ -29,6 +29,7 @@ import Distribution.Client.ProjectConfig.Types
 import Distribution.Client.Types
          ( RemoteRepo(..), emptyRemoteRepo
          , AllowNewer(..), AllowOlder(..) )
+import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
 
 import Distribution.Client.Config
          ( SavedConfig(..), remoteRepoFields )
@@ -41,9 +42,7 @@ import Distribution.Solver.Types.ConstraintSource
 
 import Distribution.Package
 import Distribution.PackageDescription
-         ( SourceRepo(..), RepoKind(..)
-         , dispFlagAssignment )
-import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
+         ( dispFlagAssignment )
 import Distribution.Simple.Compiler
          ( OptimisationLevel(..), DebugInfoLevel(..) )
 import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
@@ -89,6 +88,7 @@ import Distribution.Types.PackageVersionConstraint
          ( PackageVersionConstraint )
 
 import qualified Data.Map as Map
+
 ------------------------------------------------------------------
 -- Representing the project config file in terms of legacy types
 --
@@ -105,7 +105,7 @@ import qualified Data.Map as Map
 data LegacyProjectConfig = LegacyProjectConfig {
        legacyPackages          :: [String],
        legacyPackagesOptional  :: [String],
-       legacyPackagesRepo      :: [SourceRepo],
+       legacyPackagesRepo      :: [SourceRepoList],
        legacyPackagesNamed     :: [PackageVersionConstraint],
 
        legacySharedConfig      :: LegacySharedConfig,
@@ -1194,7 +1194,7 @@ legacyPackageConfigSectionDescrs =
 packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig
 packageRepoSectionDescr = FGSectionDescr
   { fgSectionName        = "source-repository-package"
-  , fgSectionGrammar     = sourceRepoFieldGrammar (RepoKindUnknown "unused")
+  , fgSectionGrammar     = sourceRepositoryPackageGrammar
   , fgSectionGet         = map (\x->("", x)) . legacyPackagesRepo
   , fgSectionSet         =
         \lineno unused pkgrepo projconf -> do
diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs
index 7472102c9b..11b590d935 100644
--- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs
@@ -29,6 +29,7 @@ import Distribution.Client.Targets
          ( UserConstraint )
 import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
+import Distribution.Client.SourceRepo (SourceRepoList)
 
 import Distribution.Client.IndexUtils.Timestamp
          ( IndexState )
@@ -48,7 +49,7 @@ import Distribution.Version
 import Distribution.System
          ( Platform )
 import Distribution.PackageDescription
-         ( FlagAssignment, SourceRepo(..) )
+         ( FlagAssignment )
 import Distribution.Simple.Compiler
          ( Compiler, CompilerFlavor
          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )
@@ -107,7 +108,7 @@ data ProjectConfig
        projectPackagesOptional      :: [String],
 
        -- | Packages in this project from remote source repositories.
-       projectPackagesRepo          :: [SourceRepo],
+       projectPackagesRepo          :: [SourceRepoList],
 
        -- | Packages in this project from hackage repositories.
        projectPackagesNamed         :: [PackageVersionConstraint],
diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs
index ce866b064e..1c2beb86fd 100644
--- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs
+++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs
@@ -20,6 +20,7 @@ import           Distribution.Client.ProjectBuilding.Types
 import           Distribution.Client.DistDirLayout
 import           Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId)
 import           Distribution.Client.PackageHash (showHashValue, hashValue)
+import           Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
 
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import qualified Distribution.Client.Utils.Json as J
@@ -212,15 +213,14 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
                      , "uri"  J..= J.String (show (remoteRepoURI repoRemote))
                      ]
 
-      sourceRepoToJ :: PD.SourceRepo -> J.Value
-      sourceRepoToJ PD.SourceRepo{..} =
+      sourceRepoToJ :: SourceRepoMaybe -> J.Value
+      sourceRepoToJ SourceRepositoryPackage{..} =
         J.object $ filter ((/= J.Null) . snd) $
-          [ "type"     J..= fmap jdisplay repoType
-          , "location" J..= fmap J.String repoLocation
-          , "module"   J..= fmap J.String repoModule
-          , "branch"   J..= fmap J.String repoBranch
-          , "tag"      J..= fmap J.String repoTag
-          , "subdir"   J..= fmap J.String repoSubdir
+          [ "type"     J..= jdisplay srpType
+          , "location" J..= J.String srpLocation
+          , "branch"   J..= fmap J.String srpBranch
+          , "tag"      J..= fmap J.String srpTag
+          , "subdir"   J..= fmap J.String srpSubdir
           ]
 
       dist_dir = distBuildDirectory distDirLayout
diff --git a/cabal-install/Distribution/Client/SourceRepo.hs b/cabal-install/Distribution/Client/SourceRepo.hs
new file mode 100644
index 0000000000..ac8e91b625
--- /dev/null
+++ b/cabal-install/Distribution/Client/SourceRepo.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Distribution.Client.SourceRepo where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+import Distribution.Compat.Lens (Lens, Lens')
+
+import Distribution.Types.SourceRepo
+         ( RepoType(..))
+import Distribution.FieldGrammar (FieldGrammar, ParsecFieldGrammar', PrettyFieldGrammar', uniqueField, uniqueFieldAla, optionalFieldAla, monoidalFieldAla)
+import Distribution.Parsec.Newtypes (Token (..), FilePathNT (..), alaList', NoCommaFSep (..))
+
+-- | @source-repository-package@ definition
+--
+data SourceRepositoryPackage f = SourceRepositoryPackage
+    { srpType     :: !RepoType
+    , srpLocation :: !String
+    , srpTag      :: !(Maybe String)
+    , srpBranch   :: !(Maybe String)
+    , srpSubdir   :: !(f FilePath)
+    }
+  deriving (Generic)
+
+deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)
+deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)
+deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)
+deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)
+
+-- | Read from @cabal.project@
+type SourceRepoList  = SourceRepositoryPackage []
+
+-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'
+type SourceRepoMaybe = SourceRepositoryPackage Maybe
+
+-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.
+type SourceRepoProxy = SourceRepositoryPackage Proxy
+
+srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g
+srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }
+
+srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy
+srpToProxy s = s { srpSubdir = Proxy }
+
+-- | Split single @source-repository-package@ declaration with multiple subdirs,
+-- into multiple ones with at most single subdir.
+srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)
+srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =
+    s { srpSubdir = Nothing } :| []
+srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where
+    f subdir = s { srpSubdir = Just subdir }
+
+-------------------------------------------------------------------------------
+-- Lens
+-------------------------------------------------------------------------------
+
+srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType
+srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))
+{-# INLINE srpTypeLens #-}
+
+srpLocationLens :: Lens' (SourceRepositoryPackage f) String
+srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))
+{-# INLINE srpLocationLens #-}
+
+srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
+srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))
+{-# INLINE srpTagLens #-}
+
+srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
+srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))
+{-# INLINE srpBranchLens #-}
+
+srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)
+srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))
+{-# INLINE srpSubdirLens #-}
+
+-------------------------------------------------------------------------------
+-- Parser & PPrinter
+-------------------------------------------------------------------------------
+
+sourceRepositoryPackageGrammar
+    :: (FieldGrammar g, Applicative (g SourceRepoList))
+    => g SourceRepoList SourceRepoList
+sourceRepositoryPackageGrammar = SourceRepositoryPackage
+    <$> uniqueField      "type"                                       srpTypeLens
+    <*> uniqueFieldAla   "location" Token                             srpLocationLens
+    <*> optionalFieldAla "tag"      Token                             srpTagLens
+    <*> optionalFieldAla "branch"   Token                             srpBranchLens
+    <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...
+{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}
+{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
diff --git a/cabal-install/Distribution/Client/SourceRepoParse.hs b/cabal-install/Distribution/Client/SourceRepoParse.hs
deleted file mode 100644
index dcdb3ef700..0000000000
--- a/cabal-install/Distribution/Client/SourceRepoParse.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Distribution.Client.SourceRepoParse where
-
-import Distribution.Client.Compat.Prelude
-import Prelude ()
-
-import Distribution.Deprecated.ParseUtils           (FieldDescr (..), syntaxError)
-import Distribution.FieldGrammar.FieldDescrs        (fieldDescrsToList)
-import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
-import Distribution.Parsec                          (explicitEitherParsec)
-import Distribution.Simple.Utils                    (fromUTF8BS)
-import Distribution.Types.SourceRepo                (RepoKind (..), SourceRepo)
-
-sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
-sourceRepoFieldDescrs =
-    map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused")
-  where
-    toDescr (name, pretty, parse) = FieldDescr
-        { fieldName = fromUTF8BS name
-        , fieldGet  = pretty
-        , fieldSet  = \lineNo str x ->
-              either (syntaxError lineNo) return
-              $ explicitEitherParsec (parse x) str
-        }
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 8ae60f5531..ecaa147aa7 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -48,8 +48,8 @@ import Distribution.Types.ComponentName
          ( ComponentName(..) )
 import Distribution.Types.LibraryName
          ( LibraryName(..) )
-import Distribution.Types.SourceRepo
-         ( SourceRepo )
+import Distribution.Client.SourceRepo
+         ( SourceRepoMaybe )
 
 import Distribution.Solver.Types.PackageIndex
          ( PackageIndex )
@@ -287,7 +287,7 @@ data PackageLocation local =
   | RepoTarballPackage Repo PackageId local
 
     -- | A package available from a version control system source repository
-  | RemoteSourceRepoPackage SourceRepo local
+  | RemoteSourceRepoPackage SourceRepoMaybe local
   deriving (Show, Functor, Eq, Ord, Generic, Typeable)
 
 instance Binary local => Binary (PackageLocation local)
diff --git a/cabal-install/Distribution/Client/VCS.hs b/cabal-install/Distribution/Client/VCS.hs
index 89f4c94aec..9d897d77c7 100644
--- a/cabal-install/Distribution/Client/VCS.hs
+++ b/cabal-install/Distribution/Client/VCS.hs
@@ -1,20 +1,16 @@
-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
 module Distribution.Client.VCS (
     -- * VCS driver type
     VCS,
     vcsRepoType,
     vcsProgram,
     -- ** Type re-exports
-    SourceRepo,
     RepoType,
-    RepoKind,
     Program,
     ConfiguredProgram,
 
-    -- * Selecting amongst source repos
-    selectPackageSourceRepo,
-
     -- * Validating 'SourceRepo's and configuring VCS drivers
+    validatePDSourceRepo,
     validateSourceRepo,
     validateSourceRepos,
     SourceRepoProblem(..),
@@ -38,7 +34,8 @@ import Prelude ()
 import Distribution.Client.Compat.Prelude
 
 import Distribution.Types.SourceRepo
-         ( SourceRepo(..), RepoType(..), RepoKind(..) )
+         ( RepoType(..) )
+import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
 import Distribution.Client.RebuildMonad
          ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
 import Distribution.Verbosity as Verbosity
@@ -51,6 +48,7 @@ import Distribution.Simple.Program
          , emptyProgramDb, requireProgram )
 import Distribution.Version
          ( mkVersion )
+import qualified Distribution.PackageDescription as PD
 
 import Control.Monad
          ( mapM_ )
@@ -58,8 +56,6 @@ import Control.Monad.Trans
          ( liftIO )
 import qualified Data.Char as Char
 import qualified Data.Map  as Map
-import Data.Ord
-         ( comparing )
 import Data.Either
          ( partitionEithers )
 import System.FilePath
@@ -80,9 +76,9 @@ data VCS program = VCS {
 
        -- | The program invocation(s) to get\/clone a repository into a fresh
        -- local directory.
-       vcsCloneRepo :: Verbosity
+       vcsCloneRepo :: forall f. Verbosity
                     -> ConfiguredProgram
-                    -> SourceRepo
+                    -> SourceRepositoryPackage f
                     -> FilePath   -- Source URI
                     -> FilePath   -- Destination directory
                     -> [ProgramInvocation],
@@ -90,9 +86,9 @@ data VCS program = VCS {
        -- | The program invocation(s) to synchronise a whole set of /related/
        -- repositories with corresponding local directories. Also returns the
        -- files that the command depends on, for change monitoring.
-       vcsSyncRepos :: Verbosity
+       vcsSyncRepos :: forall f. Verbosity
                     -> ConfiguredProgram
-                    -> [(SourceRepo, FilePath)]
+                    -> [(SourceRepositoryPackage f, FilePath)]
                     -> IO [MonitorFilePath]
      }
 
@@ -101,37 +97,8 @@ data VCS program = VCS {
 -- * Selecting repos and drivers
 -- ------------------------------------------------------------
 
--- | Pick the 'SourceRepo' to use to get the package sources from.
---
--- Note that this does /not/ depend on what 'VCS' drivers we are able to
--- successfully configure. It is based only on the 'SourceRepo's declared
--- in the package, and optionally on a preferred 'RepoKind'.
---
-selectPackageSourceRepo :: Maybe RepoKind
-                        -> [SourceRepo]
-                        -> Maybe SourceRepo
-selectPackageSourceRepo preferredRepoKind =
-    listToMaybe
-    -- Sort repositories by kind, from This to Head to Unknown. Repositories
-    -- with equivalent kinds are selected based on the order they appear in
-    -- the Cabal description file.
-  . sortBy (comparing thisFirst)
-    -- If the user has specified the repo kind, filter out the repositories
-    -- they're not interested in.
-  . filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind)
-  where
-    thisFirst :: SourceRepo -> Int
-    thisFirst r = case repoKind r of
-        RepoThis -> 0
-        RepoHead -> case repoTag r of
-            -- If the type is 'head' but the author specified a tag, they
-            -- probably meant to create a 'this' repository but screwed up.
-            Just _  -> 0
-            Nothing -> 1
-        RepoKindUnknown _ -> 2
-
 data SourceRepoProblem = SourceRepoRepoTypeUnspecified
-                       | SourceRepoRepoTypeUnsupported RepoType
+                       | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
                        | SourceRepoLocationUnspecified
   deriving Show
 
@@ -140,25 +107,42 @@ data SourceRepoProblem = SourceRepoRepoTypeUnspecified
 --
 -- | It also returns the 'VCS' driver we should use to work with it.
 --
-validateSourceRepo :: SourceRepo
-                   -> Either SourceRepoProblem
-                             (SourceRepo, String, RepoType, VCS Program)
+validateSourceRepo
+    :: SourceRepositoryPackage f
+    -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
 validateSourceRepo = \repo -> do
-    rtype <- repoType repo               ?! SourceRepoRepoTypeUnspecified
-    vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported rtype
-    uri   <- repoLocation repo           ?! SourceRepoLocationUnspecified
+    let rtype = srpType repo
+    vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
+    let uri = srpLocation repo
     return (repo, uri, rtype, vcs)
   where
     a ?! e = maybe (Left e) Right a
 
+validatePDSourceRepo
+    :: PD.SourceRepo
+    -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
+validatePDSourceRepo repo = do
+    rtype <- PD.repoType repo      ?! SourceRepoRepoTypeUnspecified
+    uri   <- PD.repoLocation repo  ?! SourceRepoLocationUnspecified
+    validateSourceRepo SourceRepositoryPackage
+        { srpType     = rtype
+        , srpLocation = uri
+        , srpTag      = PD.repoTag repo
+        , srpBranch   = PD.repoBranch repo
+        , srpSubdir   = PD.repoSubdir repo
+        }
+  where
+    a ?! e = maybe (Left e) Right a
+
+
 
 -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
 -- things in a convenient form to pass to 'configureVCSs', or to report
 -- problems.
 --
-validateSourceRepos :: [SourceRepo]
-                    -> Either [(SourceRepo, SourceRepoProblem)]
-                              [(SourceRepo, String, RepoType, VCS Program)]
+validateSourceRepos :: [SourceRepositoryPackage f]
+                    -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]
+                              [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
 validateSourceRepos rs =
     case partitionEithers (map validateSourceRepo' rs) of
       (problems@(_:_), _) -> Left problems
@@ -193,17 +177,15 @@ configureVCSs verbosity = traverse (configureVCS verbosity)
 --
 -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
 --
-cloneSourceRepo :: Verbosity
-                -> VCS ConfiguredProgram
-                -> SourceRepo -- ^ Must have 'repoLocation' filled.
-                -> FilePath   -- ^ Destination directory
-                -> IO ()
-cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ =
-    error $ "cloneSourceRepo: precondition violation, missing repoLocation: \""
-         ++ show repo ++ "\". Validate using validateSourceRepo first."
 
+cloneSourceRepo
+    :: Verbosity
+    -> VCS ConfiguredProgram
+    -> SourceRepositoryPackage f
+    -> [Char]
+    -> IO ()
 cloneSourceRepo verbosity vcs
-                repo@SourceRepo{ repoLocation = Just srcuri } destdir =
+                repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =
     mapM_ (runProgramInvocation verbosity) invocations
   where
     invocations = vcsCloneRepo vcs verbosity
@@ -228,7 +210,7 @@ cloneSourceRepo verbosity vcs
 --
 syncSourceRepos :: Verbosity
                 -> VCS ConfiguredProgram
-                -> [(SourceRepo, FilePath)]
+                -> [(SourceRepositoryPackage f, FilePath)]
                 -> Rebuild ()
 syncSourceRepos verbosity vcs repos = do
     files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
@@ -260,7 +242,7 @@ vcsBzr =
   where
     vcsCloneRepo :: Verbosity
                  -> ConfiguredProgram
-                 -> SourceRepo
+                 -> SourceRepositoryPackage f
                  -> FilePath
                  -> FilePath
                  -> [ProgramInvocation]
@@ -274,13 +256,13 @@ vcsBzr =
                               = "branch"
                   | otherwise = "get"
 
-        tagArgs = case repoTag repo of
+        tagArgs = case srpTag repo of
           Nothing  -> []
           Just tag -> ["-r", "tag:" ++ tag]
         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
 
     vcsSyncRepos :: Verbosity -> ConfiguredProgram
-                 -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
+                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
 
 bzrProgram :: Program
@@ -306,7 +288,7 @@ vcsDarcs =
   where
     vcsCloneRepo :: Verbosity
                  -> ConfiguredProgram
-                 -> SourceRepo
+                 -> SourceRepositoryPackage f
                  -> FilePath
                  -> FilePath
                  -> [ProgramInvocation]
@@ -319,13 +301,13 @@ vcsDarcs =
         cloneCmd   | programVersion prog >= Just (mkVersion [2,8])
                                = "clone"
                    | otherwise = "get"
-        tagArgs    = case repoTag repo of
+        tagArgs    = case srpTag repo of
           Nothing  -> []
           Just tag -> ["-t", tag]
         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
 
     vcsSyncRepos :: Verbosity -> ConfiguredProgram
-                 -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
+                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"
 
 darcsProgram :: Program
@@ -351,7 +333,7 @@ vcsGit =
   where
     vcsCloneRepo :: Verbosity
                  -> ConfiguredProgram
-                 -> SourceRepo
+                 -> SourceRepositoryPackage f
                  -> FilePath
                  -> FilePath
                  -> [ProgramInvocation]
@@ -361,11 +343,11 @@ vcsGit =
      ++ [ (programInvocation prog (checkoutArgs tag)) {
             progInvokeCwd = Just destdir
           }
-        | tag <- maybeToList (repoTag repo) ]
+        | tag <- maybeToList (srpTag repo) ]
       where
         cloneArgs  = ["clone", srcuri, destdir]
                      ++ branchArgs ++ verboseArg
-        branchArgs = case repoBranch repo of
+        branchArgs = case srpBranch repo of
           Just b  -> ["--branch", b]
           Nothing -> []
         checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]
@@ -373,7 +355,7 @@ vcsGit =
 
     vcsSyncRepos :: Verbosity
                  -> ConfiguredProgram
-                 -> [(SourceRepo, FilePath)]
+                 -> [(SourceRepositoryPackage f, FilePath)]
                  -> IO [MonitorFilePath]
     vcsSyncRepos _ _ [] = return []
     vcsSyncRepos verbosity gitProg
@@ -383,10 +365,10 @@ vcsGit =
       sequence_
         [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
         | (repo, localDir) <- secondaryRepos ]
-      return [ monitorDirectoryExistence dir 
+      return [ monitorDirectoryExistence dir
              | dir <- (primaryLocalDir : map snd secondaryRepos) ]
 
-    vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do
+    vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do
         exists <- doesDirectoryExist localDir
         if exists
           then git localDir                 ["fetch"]
@@ -404,10 +386,10 @@ vcsGit =
                            Nothing           -> []
                            Just peerLocalDir -> ["--reference", peerLocalDir]
                       ++ verboseArg
-                         where Just loc = repoLocation
+                         where loc = srpLocation
         checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"
                          , checkoutTarget, "--" ]
-        checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag)
+        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
         verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]
 
 gitProgram :: Program
@@ -444,7 +426,7 @@ vcsHg =
   where
     vcsCloneRepo :: Verbosity
                  -> ConfiguredProgram
-                 -> SourceRepo
+                 -> SourceRepositoryPackage f
                  -> FilePath
                  -> FilePath
                  -> [ProgramInvocation]
@@ -453,17 +435,17 @@ vcsHg =
       where
         cloneArgs  = ["clone", srcuri, destdir]
                      ++ branchArgs ++ tagArgs ++ verboseArg
-        branchArgs = case repoBranch repo of
+        branchArgs = case srpBranch repo of
           Just b  -> ["--branch", b]
           Nothing -> []
-        tagArgs = case repoTag repo of
+        tagArgs = case srpTag repo of
           Just t  -> ["--rev", t]
           Nothing -> []
         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
 
     vcsSyncRepos :: Verbosity
                  -> ConfiguredProgram
-                 -> [(SourceRepo, FilePath)]
+                 -> [(SourceRepositoryPackage f, FilePath)]
                  -> IO [MonitorFilePath]
     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"
 
@@ -490,7 +472,7 @@ vcsSvn =
   where
     vcsCloneRepo :: Verbosity
                  -> ConfiguredProgram
-                 -> SourceRepo
+                 -> SourceRepositoryPackage f
                  -> FilePath
                  -> FilePath
                  -> [ProgramInvocation]
@@ -503,7 +485,7 @@ vcsSvn =
 
     vcsSyncRepos :: Verbosity
                  -> ConfiguredProgram
-                 -> [(SourceRepo, FilePath)]
+                 -> [(SourceRepositoryPackage f, FilePath)]
                  -> IO [MonitorFilePath]
     vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
 
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index d50e934899..bd2a08ab0d 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -239,7 +239,7 @@ executable cabal
         Distribution.Client.SetupWrapper
         Distribution.Client.SolverInstallPlan
         Distribution.Client.SourceFiles
-        Distribution.Client.SourceRepoParse
+        Distribution.Client.SourceRepo
         Distribution.Client.SrcDist
         Distribution.Client.Store
         Distribution.Client.Tar
diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp
index 0f4d208b02..e7a636d12e 100644
--- a/cabal-install/cabal-install.cabal.pp
+++ b/cabal-install/cabal-install.cabal.pp
@@ -168,7 +168,7 @@ Version:            3.1.0.0
         Distribution.Client.SetupWrapper
         Distribution.Client.SolverInstallPlan
         Distribution.Client.SourceFiles
-        Distribution.Client.SourceRepoParse
+        Distribution.Client.SourceRepo
         Distribution.Client.SrcDist
         Distribution.Client.Store
         Distribution.Client.Tar
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
index 986896032c..7fa902740b 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
@@ -5,7 +5,8 @@ import Distribution.Client.Get
 
 import Distribution.Types.PackageId
 import Distribution.Types.PackageName
-import Distribution.Types.SourceRepo
+import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..))
+import Distribution.Client.SourceRepo (SourceRepositoryPackage (..))
 import Distribution.Verbosity as Verbosity
 import Distribution.Version
 
@@ -92,11 +93,19 @@ testUnsupportedRepoType :: Assertion
 testUnsupportedRepoType = do
     e <- assertException $
            clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
-    e @?= ClonePackageUnsupportedRepoType pkgidfoo repo repotype
+    e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype
   where
     pkgrepos = [(pkgidfoo, [repo])]
-    repo     = (emptySourceRepo RepoHead) {
-                 repoType = Just repotype
+    repo     = (emptySourceRepo RepoHead)
+               { repoType     = Just repotype
+               , repoLocation = Just "loc"
+               }
+    repo'    = SourceRepositoryPackage
+               { srpType     = repotype
+               , srpLocation = "loc"
+               , srpTag      = Nothing
+               , srpBranch   = Nothing
+               , srpSubdir   = Proxy
                }
     repotype = OtherRepoType "baz"
 
@@ -169,10 +178,17 @@ testGitFetchFailed =
                        repoType     = Just Git,
                        repoLocation = Just srcdir
                      }
+          repo'    = SourceRepositoryPackage
+                     { srpType     = Git
+                     , srpLocation = srcdir
+                     , srpTag      = Nothing
+                     , srpBranch   = Nothing
+                     , srpSubdir   = Proxy
+                     }
           pkgrepos = [(pkgidfoo, [repo])]
       e1 <- assertException $
               clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
-      e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo "git" (ExitFailure 128)
+      e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128)
 
 
 testNetworkGitClone :: Assertion
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index f8c4969d2e..9562d6213f 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module UnitTests.Distribution.Client.ProjectConfig (tests) where
@@ -16,7 +17,7 @@ import Distribution.Deprecated.Text as Text
 import qualified Distribution.Deprecated.ReadP as Parse
 
 import Distribution.Package
-import Distribution.PackageDescription hiding (Flag)
+import Distribution.PackageDescription hiding (Flag, SourceRepo)
 import Distribution.Compiler
 import Distribution.Version
 import Distribution.Simple.Compiler
@@ -33,6 +34,7 @@ import Distribution.Client.InstallSymlink
 import Distribution.Client.Dependency.Types
 import Distribution.Client.BuildReports.Types
 import Distribution.Client.Targets
+import Distribution.Client.SourceRepo
 import Distribution.Utils.NubList
 import Network.URI
 
@@ -173,7 +175,7 @@ prop_roundtrip_printparse_all config =
 
 prop_roundtrip_printparse_packages :: [PackageLocationString]
                                    -> [PackageLocationString]
-                                   -> [SourceRepo]
+                                   -> [SourceRepoList]
                                    -> [PackageVersionConstraint]
                                    -> Property
 prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =
@@ -762,35 +764,24 @@ instance Arbitrary HaddockTarget where
 instance Arbitrary TestShowDetails where
     arbitrary = arbitraryBoundedEnum
 
-instance Arbitrary SourceRepo where
-    arbitrary = (SourceRepo kind
-                           <$> arbitrary
-                           <*> (fmap getShortToken <$> arbitrary)
-                           <*> (fmap getShortToken <$> arbitrary)
-                           <*> (fmap getShortToken <$> arbitrary)
-                           <*> (fmap getShortToken <$> arbitrary)
-                           <*> (fmap getShortToken <$> arbitrary))
-                `suchThat` (/= emptySourceRepo kind)
-      where
-        kind = RepoKindUnknown "unused"
-
-    shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =
-      [ repo
-      | ((x1', x2', x3'), (x4', x5', x6'))
-          <- shrink ((x1,
-                      fmap ShortToken x2,
-                      fmap ShortToken x3),
-                     (fmap ShortToken x4,
-                      fmap ShortToken x5,
-                      fmap ShortToken x6))
-      , let repo = SourceRepo RepoThis x1'
-                              (fmap getShortToken x2')
-                              (fmap getShortToken x3')
-                              (fmap getShortToken x4')
-                              (fmap getShortToken x5')
-                              (fmap getShortToken x6')
-      , repo /= emptySourceRepo RepoThis
-      ]
+instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
+    arbitrary = SourceRepositoryPackage
+        <$> arbitrary
+        <*> (getShortToken <$> arbitrary)
+        <*> (fmap getShortToken <$> arbitrary)
+        <*> (fmap getShortToken <$> arbitrary)
+        <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
+
+    shrink (SourceRepositoryPackage x1 x2 x3 x4 x5) =
+        [ SourceRepositoryPackage
+            x1'
+            (getShortToken x2')
+            (fmap getShortToken x3')
+            (fmap getShortToken x4')
+            (fmap getShortToken x5')
+        | (x1', x2', x3', x4', x5') <- shrink
+          (x1, ShortToken x2, fmap ShortToken x3, fmap ShortToken x4, fmap ShortToken x5)
+        ]
 
 instance Arbitrary RepoType where
     arbitrary = elements knownRepoTypes
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
index 49c9a925ff..4d5757f18c 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module UnitTests.Distribution.Client.TreeDiffInstances () where
@@ -33,6 +34,7 @@ import Distribution.Client.IndexUtils.Timestamp
 import Distribution.Client.InstallSymlink
 import Distribution.Client.ProjectConfig.Types
 import Distribution.Client.Targets
+import Distribution.Client.SourceRepo (SourceRepositoryPackage)
 import Distribution.Client.Types
 
 import UnitTests.Distribution.Client.GenericInstances ()
@@ -90,6 +92,7 @@ instance ToExpr RepoType
 instance ToExpr ReportLevel
 instance ToExpr ShortText
 instance ToExpr SourceRepo
+instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f)
 instance ToExpr StrongFlags
 instance ToExpr TestShowDetails
 instance ToExpr Timestamp
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
index 46700bf2ef..bb32db032e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
@@ -1,22 +1,20 @@
 {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 module UnitTests.Distribution.Client.VCS (tests) where
 
+import Distribution.Client.Compat.Prelude
 import Distribution.Client.VCS
 import Distribution.Client.RebuildMonad
          ( execRebuild )
 import Distribution.Simple.Program
 import Distribution.Verbosity as Verbosity
-import Distribution.Types.SourceRepo
+import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy)
 
 import Data.List
 import Data.Tuple
 import qualified Data.Map as Map
-import Data.Map (Map)
 import qualified Data.Set as Set
 import Data.Set (Set)
-import Data.Char (isSpace)
 
-import Control.Monad
 import qualified Control.Monad.State as State
 import Control.Monad.State (StateT, liftIO, execStateT)
 import Control.Exception
@@ -196,11 +194,13 @@ prop_cloneRepo vcs mkVCSTestDriver repoRecipe =
         removeDirectoryRecursiveHack verbosity destRepoPath
       where
         destRepoPath = tmpdir </> "dest"
-        repo = (emptySourceRepo RepoThis) {
-                 repoType     = Just (vcsRepoType vcsVCS),
-                 repoLocation = Just vcsRepoRoot,
-                 repoTag      = Just tagname
-               }
+        repo = SourceRepositoryPackage
+            { srpType     = vcsRepoType vcsVCS
+            , srpLocation = vcsRepoRoot
+            , srpTag      = Just tagname
+            , srpBranch   = Nothing
+            , srpSubdir   = []
+            }
     verbosity = silent
 
 
@@ -264,7 +264,7 @@ checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles }
                (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) =
     mapM_ checkSyncTargetSet syncTargetSets
   where
-    checkSyncTargetSet :: [(SourceRepo, FilePath, RepoWorkingState)] -> IO ()
+    checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO ()
     checkSyncTargetSet syncTargets = do
       _ <- execRebuild "root-unused" $
            syncSourceRepos verbosity vcs
@@ -282,22 +282,24 @@ checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles }
 pickSyncTargetSets :: RepoType -> RepoState
                    -> FilePath -> [FilePath]
                    -> StdGen
-                   -> [[(SourceRepo, FilePath, RepoWorkingState)]]
+                   -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]]
 pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =
     assert (Map.size (allTags repoState) > 0) $
     unfoldr (Just . swap . pickSyncTargetSet)
   where
-    pickSyncTargetSet :: Rand [(SourceRepo, FilePath, RepoWorkingState)]
+    pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)]
     pickSyncTargetSet = flip (mapAccumL (flip pickSyncTarget)) dstReposPath
 
-    pickSyncTarget :: FilePath -> Rand (SourceRepo, FilePath, RepoWorkingState)
+    pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState)
     pickSyncTarget destRepoPath prng =
         (prng', (repo, destRepoPath, workingState))
       where
-        repo                = (emptySourceRepo RepoThis) {
-                                repoType     = Just repoType,
-                                repoLocation = Just srcRepoPath,
-                                repoTag      = Just tag
+        repo                = SourceRepositoryPackage
+                              { srpType     = repoType
+                              , srpLocation = srcRepoPath
+                              , srpTag      = Just tag
+                              , srpBranch   = Nothing
+                              , srpSubdir   = Proxy
                               }
         (tag, workingState) = Map.elemAt tagIdx (allTags repoState)
         (tagIdx, prng')     = randomR (0, Map.size (allTags repoState) - 1) prng
-- 
GitLab