Merge pull request #7276 from fendor/polish/replace-list-with-non-empty

Replace List with NonEmpty in TargetsMap

Author: fendor

cabal-install/cabal-install.cabal

@@ -278,6 +278,7 @@ Test-Suite unit-tests
       UnitTests.Distribution.Client.TreeDiffInstances
       UnitTests.Distribution.Client.UserConfig
       UnitTests.Distribution.Client.ProjectConfig
+      UnitTests.Distribution.Client.ProjectPlanning
       UnitTests.Distribution.Client.JobControl
       UnitTests.Distribution.Client.IndexUtils
       UnitTests.Distribution.Client.IndexUtils.Timestamp

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

@@ -130,6 +130,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.Ord
          ( Down(..) )
 import qualified Data.Map as Map
+import qualified Data.List.NonEmpty as NE
 import Distribution.Utils.NubList
          ( fromNubList )
 import Network.URI (URI)
@@ -483,7 +484,7 @@ partitionToKnownTargetsAndHackagePackages
   -> SourcePackageDb
   -> ElaboratedInstallPlan
   -> [TargetSelector]
-  -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName])
+  -> IO (TargetsMap, [PackageName])
 partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
   let mTargets = resolveTargets
         selectPackageTargets
@@ -693,7 +694,7 @@ warnIfNoExes verbosity buildCtx =
   where
     targets    = concat $ Map.elems $ targetsMap buildCtx
     components = fst <$> targets
-    selectors  = concatMap snd targets
+    selectors  = concatMap (NE.toList . snd) targets
     noExes     = null $ catMaybes $ exeMaybe <$> components
 
     exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
@@ -757,7 +758,7 @@ installUnitExes
   -> FilePath
   -> InstallMethod
   -> ( UnitId
-     , [(ComponentTarget, [TargetSelector])] )
+     , [(ComponentTarget, NonEmpty TargetSelector)] )
   -> IO ()
 installUnitExes verbosity overwritePolicy
                 mkSourceBinDir mkExeName mkFinalExeName
@@ -831,12 +832,12 @@ installBuiltExe verbosity overwritePolicy
 entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
 entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
   where
-    hasLib :: (ComponentTarget, [TargetSelector]) -> Bool
+    hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
     hasLib (ComponentTarget (CLibName _) _, _) = True
     hasLib _                                   = False
 
     go :: UnitId
-       -> [(ComponentTarget, [TargetSelector])]
+       -> [(ComponentTarget, NonEmpty TargetSelector)]
        -> [GhcEnvironmentFileEntry]
     go unitId targets
       | any hasLib targets = [GhcEnvFilePackageId unitId]

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

@@ -27,7 +27,7 @@ import Distribution.Client.TargetProblem         (TargetProblem (..))
 import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)
 import Distribution.Simple.Command               (CommandUI (..))
 import Distribution.Simple.Setup                 (configVerbosity, fromFlagOrDefault)
-import Distribution.Simple.Utils                 (die', ordNub, wrapText)
+import Distribution.Simple.Utils                 (die', wrapText)
 import Distribution.System                       (Platform)
 import Distribution.Types.ComponentName          (showComponentName)
 import Distribution.Types.UnitId                 (UnitId)
@@ -341,7 +341,7 @@ renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =
 renderListBinProblem (TargetProblemMultipleTargets selectorMap) =
     "The list-bin command is for finding a single binary at once. The targets "
  ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"
-                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
+                       | ts <- uniqueTargetSelectors selectorMap ]
  ++ " refer to different executables."
 
 renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =

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

@@ -96,7 +96,7 @@ import Distribution.Utils.Generic
 import Distribution.Verbosity
          ( normal, lessVerbose )
 import Distribution.Simple.Utils
-         ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist )
+         ( wrapText, die', debugNoWrap, createTempDirectory, handleDoesNotExist )
 import Language.Haskell.Extension
          ( Language(..) )
 import Distribution.CabalSpecVersion
@@ -571,7 +571,7 @@ renderReplProblem (TargetProblemMultipleTargets selectorMap) =
     "Cannot open a repl for multiple components at once. The targets "
  ++ renderListCommaAnd
       [ "'" ++ showTargetSelector ts ++ "'"
-      | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
+      | ts <- uniqueTargetSelectors selectorMap ]
  ++ " refer to different components."
  ++ ".\n\n" ++ explanationSingleComponentLimitation
 

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

@@ -46,7 +46,7 @@ import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)
 import Distribution.Verbosity
          ( normal )
 import Distribution.Simple.Utils
-         ( wrapText, warn, die', ordNub, info
+         ( wrapText, warn, die', info
          , createTempDirectory, handleDoesNotExist )
 import Distribution.Client.ProjectConfig
          ( ProjectConfig(..), ProjectConfigShared(..)
@@ -101,7 +101,6 @@ import Language.Haskell.Extension
          ( Language(..) )
 
 import qualified Data.ByteString.Char8 as BS
-import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Text.Parsec as P
 import System.Directory
@@ -605,7 +604,7 @@ renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =
 renderRunProblem (TargetProblemMultipleTargets selectorMap) =
     "The run command is for running a single executable at once. The targets "
  ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"
-                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
+                       | ts <- uniqueTargetSelectors selectorMap ]
  ++ " refer to different executables."
 
 renderRunProblem (TargetProblemComponentNotExe pkgid cname) =

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

@@ -58,6 +58,8 @@ module Distribution.Client.ProjectOrchestration (
     reportTargetSelectorProblems,
     resolveTargets,
     TargetsMap,
+    allTargetSelectors,
+    uniqueTargetSelectors,
     TargetSelector(..),
     TargetImplicitCwd(..),
     PackageId,
@@ -151,7 +153,7 @@ import           Distribution.Simple.Command (commandShowOptions)
 import           Distribution.Simple.Configure (computeEffectiveProfiling)
 
 import           Distribution.Simple.Utils
-                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose )
+                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub )
 import           Distribution.Verbosity
 import           Distribution.Version
                    ( mkVersion )
@@ -473,7 +475,15 @@ runProjectPostBuildPhase verbosity
 -- possible to for different selectors to match the same target. This extra
 -- information is primarily to help make helpful error messages.
 --
-type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])]
+type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
+
+-- | Get all target selectors.
+allTargetSelectors :: TargetsMap -> [TargetSelector]
+allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems
+
+-- | Get all unique target selectors.
+uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
+uniqueTargetSelectors = ordNub . allTargetSelectors
 
 -- | Given a set of 'TargetSelector's, resolve which 'UnitId's and
 -- 'ComponentTarget's they ought to refer to.
@@ -529,7 +539,7 @@ resolveTargets selectPackageTargets selectComponentTarget
                  -> TargetsMap
     mkTargetsMap targets =
         Map.map nubComponentTargets
-      $ Map.fromListWith (++)
+      $ Map.fromListWith (<>)
           [ (uid, [(ct, ts)])
           | (ts, cts) <- targets
           , (uid, ct) <- cts ]

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

@@ -163,7 +163,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import           Control.Monad.State as State
 import           Control.Exception (assert)
-import           Data.List (groupBy)
+import           Data.List (groupBy, deleteBy)
 import qualified Data.List.NonEmpty as NE
 import           System.FilePath
 
@@ -1758,7 +1758,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
             -- package needs to be rebuilt.  (It needs to be done here,
             -- because the ElaboratedConfiguredPackage is where we test
             -- whether or not there have been changes.)
-            TestStanzas  -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] 
+            TestStanzas  -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ]
             BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ]
           where
             tests, benchmarks :: Maybe Bool
@@ -2503,7 +2503,7 @@ availableSourceTargets elab =
 -- We also allow for information associated with each component target, and
 -- whenever we targets subsume each other we aggregate their associated info.
 --
-nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])]
+nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)]
 nubComponentTargets =
     concatMap (wholeComponentOverrides . map snd)
   . groupBy ((==)    `on` fst)
@@ -2514,11 +2514,17 @@ nubComponentTargets =
     -- If we're building the whole component then that the only target all we
     -- need, otherwise we can have several targets within the component.
     wholeComponentOverrides :: [(ComponentTarget,  a )]
-                            -> [(ComponentTarget, [a])]
+                            -> [(ComponentTarget, NonEmpty a)]
     wholeComponentOverrides ts =
-      case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of
-        (t:_) -> [ (t, map snd ts) ]
-        []    -> [ (t,[x]) | (t,x) <- ts ]
+      case [ ta | ta@(ComponentTarget _ WholeComponent, _) <- ts ] of
+        ((t, x):_) -> 
+                let
+                    -- Delete tuple (t, x) from original list to avoid duplicates.
+                    -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'.
+                    ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts
+                in
+                    [ (t, x :| map snd ts') ]
+        []    -> [ (t, x :| []) | (t,x) <- ts ]
 
     -- Not all Cabal Setup.hs versions support sub-component targets, so switch
     -- them over to the whole component

cabal-install/tests/UnitTests.hs

@@ -16,6 +16,7 @@ import qualified UnitTests.Distribution.Client.Tar
 import qualified UnitTests.Distribution.Client.Targets
 import qualified UnitTests.Distribution.Client.UserConfig
 import qualified UnitTests.Distribution.Client.ProjectConfig
+import qualified UnitTests.Distribution.Client.ProjectPlanning
 import qualified UnitTests.Distribution.Client.JobControl
 import qualified UnitTests.Distribution.Client.IndexUtils
 import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
@@ -51,6 +52,8 @@ main =
         UnitTests.Distribution.Client.UserConfig.tests
     , testGroup "UnitTests.Distribution.Client.ProjectConfig"
         UnitTests.Distribution.Client.ProjectConfig.tests
+    , testGroup "UnitTests.Distribution.Client.ProjectPlanning"
+        UnitTests.Distribution.Client.ProjectPlanning.tests
     , testGroup "UnitTests.Distribution.Client.JobControl"
         UnitTests.Distribution.Client.JobControl.tests
     , testGroup "UnitTests.Distribution.Client.IndexUtils"

cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module UnitTests.Distribution.Client.ProjectPlanning (tests) where
+
+import Data.List.NonEmpty
+import Distribution.Client.ProjectPlanning (ComponentTarget (..), SubComponentTarget (..), nubComponentTargets)
+import Distribution.Types.ComponentName
+import Distribution.Types.LibraryName
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: [TestTree]
+tests =
+  [ testGroup "Build Target Tests" buildTargetTests
+  ]
+
+-- ----------------------------------------------------------------------------
+-- Build Target Tests
+-- ----------------------------------------------------------------------------
+
+buildTargetTests :: [TestTree]
+buildTargetTests =
+  [ testGroup "nubComponentTargets" nubComponentTargetsTests
+  ]
+
+nubComponentTargetsTests :: [TestTree]
+nubComponentTargetsTests =
+  [ testCase "Works on empty list" $
+      nubComponentTargets [] @?= ([] :: [(ComponentTarget, NonEmpty Int)])
+  , testCase "Merges targets to same component" $
+      nubComponentTargets
+        [ (mainLibModuleTarget, 1 :: Int)
+        , (mainLibFileTarget, 2)
+        ]
+        @?= [(mainLibWholeCompTarget, 1 :| [2])]
+  , testCase "Merges whole component targets" $
+      nubComponentTargets [(mainLibFileTarget, 2), (mainLibWholeCompTarget, 1 :: Int)]
+        @?= [(mainLibWholeCompTarget, 2 :| [1])],
+    testCase "Don't merge unrelated targets" $
+      nubComponentTargets
+        [ (mainLibWholeCompTarget, 1 :: Int)
+        , (exeWholeCompTarget, 2)
+        ]
+        @?= [(mainLibWholeCompTarget, pure 1), (exeWholeCompTarget, pure 2)]
+  , testCase "Merge multiple related targets" $
+      nubComponentTargets
+        [ (mainLibWholeCompTarget, 1 :: Int)
+        , (mainLibModuleTarget, 4)
+        , (exeWholeCompTarget, 2)
+        , (exeFileTarget, 3)
+        ]
+        @?= [(mainLibWholeCompTarget, 1 :| [4]), (exeWholeCompTarget, 2 :| [3])]
+  , testCase "Merge related targets, don't merge unrelated ones" $
+      nubComponentTargets
+        [ (mainLibFileTarget, 1 :: Int)
+        , (mainLibModuleTarget, 4)
+        , (exeWholeCompTarget, 2)
+        , (exeFileTarget, 3)
+        , (exe2FileTarget, 5)
+        ]
+        @?=
+          [ (mainLibWholeCompTarget, 1 :| [4])
+          , (exeWholeCompTarget, 2 :| [3])
+          , (exe2WholeCompTarget, 5 :| [])
+          ]
+  ]
+
+-- ----------------------------------------------------------------------------
+-- Utils
+-- ----------------------------------------------------------------------------
+
+mainLibWholeCompTarget :: ComponentTarget
+mainLibWholeCompTarget = ComponentTarget (CLibName LMainLibName) WholeComponent
+
+mainLibModuleTarget :: ComponentTarget
+mainLibModuleTarget = ComponentTarget (CLibName LMainLibName) (ModuleTarget "Lib")
+
+mainLibFileTarget :: ComponentTarget
+mainLibFileTarget = ComponentTarget (CLibName LMainLibName) (FileTarget "./Lib.hs")
+
+exeWholeCompTarget :: ComponentTarget
+exeWholeCompTarget = ComponentTarget (CExeName "exe") WholeComponent
+
+exeFileTarget :: ComponentTarget
+exeFileTarget = ComponentTarget (CExeName "exe") (FileTarget "./Main.hs")
+
+exe2WholeCompTarget :: ComponentTarget
+exe2WholeCompTarget = ComponentTarget (CExeName "exe2") WholeComponent
+
+exe2FileTarget :: ComponentTarget
+exe2FileTarget = ComponentTarget (CExeName "exe2") (FileTarget "./Main2.hs")