Fix some changes

haskell · Jul 27, 2018 · dad8f0a · dad8f0a
1 parent d413565
commit dad8f0a
Show file tree

Hide file tree

Showing 2 changed files with 74 additions and 70 deletions.
diff --git a/Cabal/Distribution/Types/PackageDescription/Lens.hs b/Cabal/Distribution/Types/PackageDescription/Lens.hs
@@ -13,21 +13,22 @@ import Distribution.Compiler                  (CompilerFlavor)
 import Distribution.License                   (License)
 import Distribution.ModuleName                (ModuleName)
 import Distribution.Types.Benchmark           (Benchmark, benchmarkModules)
-import Distribution.Types.Benchmark.Lens      (benchmarkName)
+import Distribution.Types.Benchmark.Lens      (benchmarkName, benchmarkBuildInfo)
+import Distribution.Types.BuildInfo           (BuildInfo)
 import Distribution.Types.BuildType           (BuildType)
 import Distribution.Types.ComponentName       (ComponentName(..))
 import Distribution.Types.Executable          (Executable, exeModules)
-import Distribution.Types.Executable.Lens     (exeName)
+import Distribution.Types.Executable.Lens     (exeName, exeBuildInfo)
 import Distribution.Types.ForeignLib          (ForeignLib, foreignLibModules)
-import Distribution.Types.ForeignLib.Lens     (foreignLibName)
+import Distribution.Types.ForeignLib.Lens     (foreignLibName, foreignLibBuildInfo)
 import Distribution.Types.Library             (Library, explicitLibModules)
-import Distribution.Types.Library.Lens        (libName)
+import Distribution.Types.Library.Lens        (libName, libBuildInfo)
 import Distribution.Types.PackageDescription  (PackageDescription)
 import Distribution.Types.PackageId           (PackageIdentifier)
 import Distribution.Types.SetupBuildInfo      (SetupBuildInfo)
 import Distribution.Types.SourceRepo          (SourceRepo)
 import Distribution.Types.TestSuite           (TestSuite, testModules)
-import Distribution.Types.TestSuite.Lens      (testName)
+import Distribution.Types.TestSuite.Lens      (testName, testBuildInfo)
 import Distribution.Types.UnqualComponentName ( UnqualComponentName )
 import Distribution.Version                   (Version, VersionRange)
 
@@ -178,3 +179,29 @@ componentModules cname = case cname of
       . traversed
       . filtered ((== name) . view nameL)
       . to modules
+
+componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo
+componentBuildInfo cname = case cname of
+    CLibName         -> 
+      library  . traversed . libBuildInfo
+    CSubLibName name -> 
+      componentBuildInfo' name subLibraries (libName . non "") libBuildInfo
+    CFLibName   name -> 
+      componentBuildInfo' name foreignLibs  foreignLibName     foreignLibBuildInfo
+    CExeName    name -> 
+      componentBuildInfo' name executables  exeName            exeBuildInfo
+    CTestName   name -> 
+      componentBuildInfo' name testSuites   testName           testBuildInfo
+    CBenchName  name ->
+      componentBuildInfo' name benchmarks   benchmarkName      benchmarkBuildInfo
+  where
+    componentBuildInfo' :: UnqualComponentName
+                         -> Traversal' PackageDescription [a]
+                         -> Traversal' a UnqualComponentName
+                         -> Traversal' a BuildInfo
+                         -> Traversal' PackageDescription BuildInfo
+    componentBuildInfo' name pdL nameL biL =
+        pdL
+      . traversed
+      . filtered ((== name) . view nameL)
+      . biL
diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs
@@ -76,8 +76,6 @@ import Distribution.Types.Library
          ( Library(..), emptyLibrary )
 import Distribution.Types.PackageId
          ( PackageIdentifier(..), PackageId )
-import Distribution.Types.UnqualComponentName
-         ( UnqualComponentName )
 import Distribution.Types.Version
          ( mkVersion, version0, nullVersion )
 import Distribution.Types.VersionRange
@@ -242,55 +240,33 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, e
           ++ "You may wish to use 'build --only-dependencies' and then "
           ++ "use 'repl'."
 
-    baseCtx' <- if null (envPackages envFlags)
-      then return baseCtx
+    (targetPkgId, originalDeps, baseCtx') <- if null (envPackages envFlags)
+      then return (Nothing, Nothing, baseCtx)
       else
         -- Unfortunately, the best way to do this is to let the normal solver
         -- help us resolve the targets, but that isn't ideal for performance,
         -- especially in the no-project case.
         withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan -> do
-          -- Interpret the targets on the command line as repl targets
-          -- (as opposed to say build or haddock targets).
-          targets <- either (reportTargetProblems verbosity) return
-                    $ resolveTargets
-                        selectPackageTargets
-                        selectComponentTarget
-                        TargetProblemCommon
-                        elaboratedPlan
-                        Nothing
-                        targetSelectors
-
-          -- Reject multiple targets, or at least targets in different
-          -- components. It is ok to have two module/file targets in the
-          -- same component, but not two that live in different components.
-          when (Set.size (distinctTargetComponents targets) > 1) $
-            reportTargetProblems verbosity
-              [TargetProblemMultipleTargets targets]
+          targets <- validatedTargets elaboratedPlan targetSelectors
 
           let
             (unitId, ((ComponentTarget cname _, _):_)) = head $ Map.toList targets
-            Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId
             deps = pkgIdToDependency <$> envPackages envFlags
 
-          return $ addDepsToProjectTarget deps pkgId cname baseCtx
+            Just targetPkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId
+            originalDeps = packageId <$> InstallPlan.directDeps elaboratedPlan unitId
+            baseCtx' = addDepsToProjectTarget deps targetPkgId cname baseCtx
+
+          return (Just targetPkgId, Just originalDeps, baseCtx')
 
     -- Now, we run the solver again with the added packages. While the graph 
     -- won't actually reflect the addition of transitive dependencies,
     -- they're going to be available already and will be offered to the REPL
     -- and that's good enough.
     buildCtx' <- runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
       -- Recalculate with updated project.
-      targets <- either (reportTargetProblems verbosity) return
-                $ resolveTargets
-                    selectPackageTargets
-                    selectComponentTarget
-                    TargetProblemCommon
-                    elaboratedPlan
-                    Nothing
-                    targetSelectors
-      when (Set.size (distinctTargetComponents targets) > 1) $
-        reportTargetProblems verbosity
-          [TargetProblemMultipleTargets targets]
+      targets <- validatedTargets elaboratedPlan targetSelectors
+
       let elaboratedPlan' = pruneInstallPlanToTargets
                               TargetActionRepl
                               targets
@@ -311,6 +287,27 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, e
     cliConfig = commandLineFlagsToProjectConfig
                   globalFlags configFlags configExFlags
                   installFlags haddockFlags
+
+    validatedTargets elaboratedPlan targetSelectors = do
+      -- Interpret the targets on the command line as repl targets
+      -- (as opposed to say build or haddock targets).
+      targets <- either (reportTargetProblems verbosity) return
+          $ resolveTargets
+              selectPackageTargets
+              selectComponentTarget
+              TargetProblemCommon
+              elaboratedPlan
+              Nothing
+              targetSelectors
+
+      -- Reject multiple targets, or at least targets in different
+      -- components. It is ok to have two module/file targets in the
+      -- same component, but not two that live in different components.
+      when (Set.size (distinctTargetComponents targets) > 1) $
+        reportTargetProblems verbosity
+          [TargetProblemMultipleTargets targets]
+
+      return targets
 
 withProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ())
 withProject cliConfig verbosity targetStrings = do
@@ -388,47 +385,27 @@ addDepsToProjectTarget :: [Dependency]
                        -> ProjectBaseContext
                        -> ProjectBaseContext
 addDepsToProjectTarget deps pkgId cname ctx = 
-    (\p -> ctx { localPackages = p }) . fmap (fmap go) . localPackages $ ctx
+    (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx
   where
-    go :: UnresolvedSourcePackage -> UnresolvedSourcePackage
-    go pkg
-      | packageId pkg /= pkgId = pkg
+    addDeps :: PackageSpecifier UnresolvedSourcePackage
+            -> PackageSpecifier UnresolvedSourcePackage
+    addDeps (SpecificSourcePackage pkg)
+      | packageId pkg /= pkgId = SpecificSourcePackage pkg
       | SourcePackage{..} <- pkg =
-        pkg { packageDescription = 
-          packageDescription & L.packageDescription . buildInfoL cname . L.targetBuildDepends %~ (deps ++) 
+        SpecificSourcePackage $ pkg { packageDescription = 
+          packageDescription & L.packageDescription 
+                             . L.componentBuildInfo cname
+                             . L.targetBuildDepends 
+                            %~ (deps ++) 
         }
+    addDeps spec = spec
 
 pkgIdToDependency :: PackageId -> Dependency
 pkgIdToDependency pkgId
   | PackageIdentifier{..} <- pkgId
   , pkgVersion == nullVersion = Dependency pkgName anyVersion
   | otherwise                 = thisPackageVersion pkgId
 
-buildInfoL :: ComponentName -> Traversal' PackageDescription BuildInfo
-buildInfoL cname = case cname of
-    CLibName         -> L.library  . traversed . L.libBuildInfo
-    CSubLibName name -> 
-      buildInfoL' name L.subLibraries (L.libName . non "") L.libBuildInfo
-    CFLibName   name -> 
-      buildInfoL' name L.foreignLibs  L.foreignLibName     L.foreignLibBuildInfo
-    CExeName    name -> 
-      buildInfoL' name L.executables  L.exeName            L.exeBuildInfo
-    CTestName   name -> 
-      buildInfoL' name L.testSuites   L.testName           L.testBuildInfo
-    CBenchName  name ->
-      buildInfoL' name L.benchmarks   L.benchmarkName      L.benchmarkBuildInfo
-  where
-    buildInfoL' :: UnqualComponentName
-                -> Traversal' PackageDescription [a]
-                -> Traversal' a UnqualComponentName
-                -> Traversal' a BuildInfo
-                -> Traversal' PackageDescription BuildInfo
-    buildInfoL' name pdL nameL biL =
-        pdL
-      . traversed
-      . filtered ((== name) . view nameL)
-      . biL
-
 -- | This defines what a 'TargetSelector' means for the @repl@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 -- or otherwise classifies the problem.