stuff

Author: andreabedini

cabal-install/cabal-install.cabal

@@ -265,6 +265,7 @@ library
       , regex-posix >= 0.96.0.0 && <0.97
       , safe-exceptions >= 0.1.7.0 && < 0.2
       , semaphore-compat >= 1.0.0 && < 1.1
+      , ansi-terminal
 
     if flag(native-dns)
       if os(windows)

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

@@ -169,9 +169,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Text.PrettyPrint hiding ((<>))
 import GHC.Stack (HasCallStack)
-import qualified Data.Tree
-import qualified Data.Graph
-import Distribution.Simple.Utils (ordNub)
+import Distribution.Client.InstallPlan (toForest, renderForest)
 
 -- ------------------------------------------------------------
 
@@ -825,7 +823,7 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = do
     [ text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
     , text "Dependency tree"
     , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
-    , renderSolverPlanTree pkgs'
+    , text (renderForest $ Graph.fromDistinctList pkgs')
     ]
 
   validateSolverResult toolchains pkgs'
@@ -890,19 +888,6 @@ renderSolverPlanScopes pkgs = vcat
     g = Graph.fromDistinctList pkgs
     -- (_g', mapG, _invG) = Data.Graph.graphFromEdges [ (pkg, Graph.nodeKey pkg,  Graph.nodeNeighbors pkg) | pkg <- pkgs]
 
-
-renderSolverPlanTree :: HasCallStack => [SolverInstallPlan.SolverPlanPackage] -> Doc
-renderSolverPlanTree pkgs = text (Data.Tree.drawForest dfs)
-  where
-    g = Graph.fromDistinctList pkgs
-
-    (graphForward, graphVertexToNode, graphKeyToVertex) = Graph.toGraph g
-    
-    dfs = fmap (fmap (prettyShow . solverId . graphVertexToNode)) $ Data.Graph.dfs graphForward roots
-    
-    Just roots = traverse graphKeyToVertex $ concat $ SolverInstallPlan.libraryRoots g : SolverInstallPlan.setupRoots g
-
-
 -- | Give an interpretation to the global 'PackagesPreference' as
 --  specific per-package 'PackageVersionPreference'.
 interpretPackagesPreference

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

@@ -196,34 +196,16 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir =
       distBuildRootDirectory
         </> prettyShow (distParamPlatform params)
         </> prettyShow (distParamCompilerId params)
-        </> prettyShow (distParamPackageId params)
-        </> ( case distParamComponentName params of
-                Nothing -> ""
-                Just (CLibName LMainLibName) -> ""
-                Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name
-                Just (CFLibName name) -> "f" </> prettyShow name
-                Just (CExeName name) -> "x" </> prettyShow name
-                Just (CTestName name) -> "t" </> prettyShow name
-                Just (CBenchName name) -> "b" </> prettyShow name
-            )
-        </> ( case distParamOptimization params of
-                NoOptimisation -> "noopt"
-                NormalOptimisation -> ""
-                MaximumOptimisation -> "opt"
-            )
-        </> ( let uid_str = prettyShow (distParamUnitId params)
-               in if uid_str == prettyShow (distParamComponentId params)
-                    then ""
-                    else uid_str
-            )
-
+        </> prettyShow (distParamUnitId params)
+ 
     distUnpackedSrcRootDirectory :: FilePath
     distUnpackedSrcRootDirectory = distDirectory </> "src"
 
     distUnpackedSrcDirectory :: PackageId -> FilePath
     distUnpackedSrcDirectory pkgid =
       distUnpackedSrcRootDirectory
         </> prettyShow pkgid
+
     -- we shouldn't get name clashes so this should be fine:
     distDownloadSrcDirectory :: FilePath
     distDownloadSrcDirectory = distUnpackedSrcRootDirectory

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

@@ -72,6 +72,9 @@ module Distribution.Client.InstallPlan
   , reverseTopologicalOrder
   , reverseDependencyClosure
   , project
+  , toForest
+  , renderForest
+  , renderPlanForest
   ) where
 
 import Distribution.Client.Compat.Prelude hiding (lookup, toList)
@@ -120,6 +123,8 @@ import GHC.Stack
 import Data.Bifunctor
 import Data.Bifoldable
 import Data.Bitraversable
+import Data.Graph (dfs, topSort)
+import Data.Tree (Tree, drawForest)
 
 -- When cabal tries to install a number of packages, including all their
 -- dependencies it has a non-trivial problem to solve.
@@ -539,6 +544,18 @@ reverseDependencyClosure plan =
   fromMaybe []
     . Graph.revClosure (planGraph plan)
 
+toForest :: Graph.Graph a -> [Tree a]
+toForest g = fmap (fmap graphVertexToNode) $ dfs graphForward (topSort graphForward)
+ 
+  where
+    (graphForward, graphVertexToNode, _graphKeyToVertex) = Graph.toGraph g
+
+renderForest :: (IsNode a, Pretty (Key a)) => Graph a -> String
+renderForest = drawForest . fmap (fmap (prettyShow . Graph.nodeKey)) . toForest
+
+renderPlanForest :: (IsNode ipkg, IsNode srcpkg, Key ipkg ~ Key srcpkg, Pretty (Key srcpkg)) => GenericInstallPlan' key ipkg srcpkg -> String
+renderPlanForest = renderForest . planGraph
+
 project
   :: HasCallStack
   => ( IsNode ipkg1, Key ipkg1 ~ keyA

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

@@ -542,7 +542,7 @@ rebuildTarget
           _ -> return ()
         return $ BuildResult DocsNotTried TestsNotTried Nothing
     | otherwise = do
-        info verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus
+        infoNoWrap verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus
         -- We rely on the 'BuildStatus' to decide which phase to start from:
         case pkgBuildStatus of
           BuildStatusDownload -> downloadPhase

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

@@ -108,7 +108,7 @@ module Distribution.Client.ProjectPlanning
   , reportPlanningFailure
   ) where
 
-import Distribution.Client.Compat.Prelude
+import Distribution.Client.Compat.Prelude hiding (get)
 import Text.PrettyPrint
   ( comma
   , fsep
@@ -231,7 +231,7 @@ import qualified Distribution.Compat.Graph as Graph
 import Control.Exception (assert)
 import Control.Monad (sequence)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.State as State (StateT (..), execStateT, gets, modify)
+import Control.Monad.State (StateT (..), evalStateT, execStateT, gets, modify, get)
 import Data.Foldable (fold)
 import Data.List (deleteBy, groupBy)
 import qualified Data.List.NonEmpty as NE
@@ -245,6 +245,7 @@ import GHC.Stack (HasCallStack)
 import Distribution.Client.InstallPlan (foldPlanPackage)
 import Distribution.Solver.Types.ResolverPackage (solverId)
 import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage
+import System.Console.ANSI
 
 -- | Check that an 'ElaboratedConfiguredPackage' actually makes
 -- sense under some 'ElaboratedSharedConfig'.
@@ -694,6 +695,23 @@ rebuildInstallPlan
           -- changes, so it's worth caching them separately.
           improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
 
+          let s = flip foldMap (InstallPlan.toList elaboratedPlan) $
+                    foldPlanPackage
+                      (Set.singleton . Graph.nodeKey)
+                      (const Set.empty)
+              badMsg s = Disp.text (setSGRCode [SetColor Foreground Vivid Red] <> s <> setSGRCode [Reset])
+              goodMsg s = Disp.text (setSGRCode [SetColor Foreground Vivid Green] <> s <> setSGRCode [Reset]) 
+          flip evalStateT s $ for_ (InstallPlan.executionOrder elaboratedPlan) $ \(ReadyPackage pkg) -> do
+            s' <- get
+            liftIO $ infoNoWrap verbosity $ show $ 
+              Disp.hang (Disp.text "Elaborated package: " <+> pretty (Graph.nodeKey pkg)) 4 $ vcat
+                [ Disp.hang (text "elabOrderDependencies") 4 $ Disp.vcat
+                    [ pretty dep <+> Disp.parens (if Set.member dep s' then goodMsg "preset" else badMsg "missing")
+                    | dep <- sort (elabOrderDependencies pkg)
+                    ]
+                ]
+            modify (Set.insert (Graph.nodeKey pkg))
+ 
           return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
     where
       fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan"
@@ -2305,15 +2323,17 @@ elaborateInstallPlan
             elabRegisterPackageDBStack = buildAndRegisterDbs elabStage
             elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage)
 
+            -- used in fixupBuildStyle :facepalm:
             elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage
             elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage
             elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage)
 
             buildAndRegisterDbs stage
               | shouldBuildInplaceOnly pkg = inplacePackageDbs stage
               | otherwise = corePackageDbs stage
+
             -- Same as corePackageDbs but with the addition of the in-place packagedb.
-            inplacePackageDbs stage = corePackageDbs stage ++ [distPackageDB (compilerId (getStage compilers stage))]
+            inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory </> "packagedb" </> prettyShow stage </> prettyShow (compilerId (getStage compilers stage)))]
 
             -- The project packagedbs (typically the global packagedb but others can be added) followed by the store.
             corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)]

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

@@ -169,7 +169,6 @@ import Distribution.Utils.Generic
   )
 
 import Distribution.Compat.Stack
-import Distribution.ReadE
 import Distribution.System (Platform (..), buildPlatform)
 import Distribution.Utils.NubList
   ( toNubListR
@@ -1139,9 +1138,10 @@ getExternalSetupMethod verbosity options pkg bt = do
                         -- when compiling a Simple Setup.hs file.
                   , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler
                   }
-          debug verbosity $ "maybeCabalLibInstalledPkgId: " ++ show maybeCabalLibInstalledPkgId
-          debug verbosity $ "cabalDep: " ++ show cabalDep
-          debug verbosity $ "packages: " ++ show selectedDeps
+          infoNoWrap verbosity $ prettyShow options'
+          infoNoWrap verbosity $ "maybeCabalLibInstalledPkgId: " ++ show maybeCabalLibInstalledPkgId
+          infoNoWrap verbosity $ "cabalDep: " ++ show cabalDep
+          infoNoWrap verbosity $ "packages: " ++ show selectedDeps
           let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
           when (useVersionMacros options') $
             rewriteFileEx verbosity (i cppMacrosFile) $