a bunch of debugging stuff

Author: andreabedini

Cabal-syntax/src/Distribution/Compat/Graph.hs

@@ -70,6 +70,8 @@ module Distribution.Compat.Graph
   , revTopSort
 
     -- * Conversions
+  , graphVertexToNode
+  , graphKeyToVertex
 
     -- ** Maps
   , toMap

Cabal/src/Distribution/Simple/Configure.hs

@@ -77,7 +77,7 @@ import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Check hiding (doesFileExist)
 import Distribution.PackageDescription.Configuration
-import Distribution.PackageDescription.PrettyPrint
+-- import Distribution.PackageDescription.PrettyPrint
 import Distribution.Simple.BuildTarget
 import Distribution.Simple.BuildToolDepends
 import Distribution.Simple.BuildWay
@@ -929,9 +929,9 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac
         , extraCoverageFor = []
         }
 
-  debug verbosity $
-    "Finalized package description:\n"
-      ++ showPackageDescription pkg_descr2
+  -- debug verbosity $
+  --   "Finalized package description:\n"
+  --     ++ showPackageDescription pkg_descr2
 
   return (lbc, pbd)
 

Cabal/src/Distribution/Simple/Utils.hs

@@ -887,9 +887,9 @@ logCommand verbosity cp = do
     "Running: " <> case Process.cmdspec cp of
       Process.ShellCommand sh -> sh
       Process.RawCommand path args -> Process.showCommandForUser path args
-  case Process.env cp of
-    Just env -> debugNoWrap verbosity $ "with environment: " ++ show env
-    Nothing -> return ()
+  -- case Process.env cp of
+  --   Just env -> debugNoWrap verbosity $ "with environment: " ++ show env
+  --   Nothing -> return ()
   case Process.cwd cp of
     Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd
     Nothing -> return ()

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -22,7 +22,7 @@ import Distribution.Compat.Graph
 import Distribution.Compiler
          ( CompilerInfo )
 import Distribution.Solver.Modular.Assignment
-         ( Assignment, toCPs )
+         ( Assignment(..), toCPs )
 import Distribution.Solver.Modular.ConfiguredConversion
          ( convCP )
 import qualified Distribution.Solver.Modular.ConflictSet as CS
@@ -34,7 +34,7 @@ import Distribution.Solver.Modular.IndexConversion
 import Distribution.Solver.Modular.Log
          ( SolverFailure(..), displayLogMessages )
 import Distribution.Solver.Modular.Package
-         ( PN )
+         ( PN, showI )
 import Distribution.Solver.Modular.RetryLog
 import Distribution.Solver.Modular.Solver
          ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
@@ -60,7 +60,15 @@ import Distribution.Solver.Types.Toolchain
 -- solver. Performs the necessary translations before and after.
 modularResolver :: SolverConfig -> DependencyResolver loc
 modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
-    uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns
+    (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns
+
+    let A pa _fa _sa = assignment
+    step (unlines [showQPN qpn ++ " -> " ++ showI i| (qpn, i) <- M.toList pa])
+
+    -- Results have to be converted into an install plan. 'convCP' removes
+    -- package qualifiers, which means that linked packages become duplicates
+    -- and can be removed.
+    return $ ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs assignment revdepmap)
   where
       cinfo = fst <$> toolchains
 
@@ -71,12 +79,6 @@ modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
         where
           pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
 
-      -- Results have to be converted into an install plan. 'convCP' removes
-      -- package qualifiers, which means that linked packages become duplicates
-      -- and can be removed.
-      postprocess a rdm = ordNubBy nodeKey $
-                          map (convCP iidx sidx) (toCPs a rdm)
-
       -- Helper function to extract the PN from a constraint.
       pcName :: PackageConstraint -> PN
       pcName (PackageConstraint scope _) = scopeToPackageName scope

cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs

@@ -52,7 +52,7 @@ data BuildState = BS {
   rdeps :: RevDepMap,               -- ^ set of all package goals, completed and open, with reverse dependencies
   open  :: [OpenGoal],              -- ^ set of still open goals (flag and package goals)
   next  :: BuildType                -- ^ kind of node to generate next
-}
+} deriving Show
 
 -- | Map of available linking targets.
 type LinkingState = M.Map (PN, I) [PackagePath]
@@ -135,6 +135,7 @@ data BuildType =
     Goals              -- ^ build a goal choice node
   | OneGoal OpenGoal   -- ^ build a node for this goal
   | Instance QPN PInfo -- ^ build a tree for a concrete instance
+  deriving Show
 
 build :: Linker BuildState -> Tree () QGoalReason
 build = ana addChildren . buildState
@@ -210,16 +211,17 @@ buildTree idx igs =
     build Linker {
         buildState = BS {
             index = idx
-          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)
-          , open  = L.map topLevelGoal qpns
+          , rdeps = M.fromList [(qpn, []) | qpn <- qpns]
+          , open  = [ PkgGoal qpn UserGoal | qpn <- qpns ]
           , next  = Goals
           }
       , linkingState = M.empty
       }
   where
-    topLevelGoal qpn = PkgGoal qpn UserGoal
+    -- The package names are interpreted as top-level goals in the host stage.
+    path = PackagePath Stage.Host QualToplevel
+    qpns = [ Q path pn | pn <- igs ]
 
-    qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs
 
 {-------------------------------------------------------------------------------
   Goals
@@ -230,6 +232,7 @@ data OpenGoal
   = FlagGoal   (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason
   | StanzaGoal (SN QPN)       (FlaggedDeps QPN)                   QGoalReason
   | PkgGoal    QPN                                                QGoalReason
+  deriving Show
 
 -- | Closes a goal, i.e., removes all the extraneous information that we
 -- need only during the build phase.

cabal-install-solver/src/Distribution/Solver/Modular/Index.hs

@@ -40,6 +40,7 @@ data PInfo = PInfo
   FlagInfo
   --
   (Maybe FailReason)
+  deriving Show
 
 -- | Info associated with each library and executable in a package instance.
 data ComponentInfo = ComponentInfo {

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -303,7 +303,7 @@ showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " re
 showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
 showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"
 showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
-showFR _ MultipleInstances                = " (multiple instances)"
+-- showFR _ MultipleInstances                = " (multiple instances)"
 showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"
 showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"
 showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"

cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs

@@ -6,7 +6,7 @@ module Distribution.Solver.Modular.Preference
     , deferWeakFlagChoices
     , enforceManualFlags
     , enforcePackageConstraints
-    , enforceSingleInstanceRestriction
+    -- , enforceSingleInstanceRestriction
     , firstGoal
     , preferBaseGoalChoice
     , preferLinked
@@ -22,7 +22,7 @@ import Distribution.Solver.Compat.Prelude
 
 import qualified Data.List as L
 import qualified Data.Map as M
-import Control.Monad.Trans.Reader (Reader, runReader, ask, local)
+-- import Control.Monad.Trans.Reader (Reader, runReader, ask, local)
 
 import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal
 
@@ -453,47 +453,47 @@ preferReallyEasyGoalChoices = go
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs)
     go x                    = x
 
--- | Monad used internally in enforceSingleInstanceRestriction
---
--- For each package instance we record the goal for which we picked a concrete
--- instance. The SIR means that for any package instance there can only be one.
-type EnforceSIR = Reader (Map (PI PN) QPN)
-
--- | Enforce ghc's single instance restriction
---
--- From the solver's perspective, this means that for any package instance
--- (that is, package name + package version) there can be at most one qualified
--- goal resolving to that instance (there may be other goals _linking_ to that
--- instance however).
-enforceSingleInstanceRestriction :: Tree d c -> Tree d c
-enforceSingleInstanceRestriction = (`runReader` M.empty) . go
-  where
-    go :: Tree d c -> EnforceSIR (Tree d c)
-
-    -- We just verify package choices.
-    go (PChoice qpn rdm gr cs) =
-      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) (fmap go cs))
-    go (FChoice qfn rdm y t m d ts) =
-      FChoice qfn rdm y t m d <$> traverse go ts
-    go (SChoice qsn rdm y t ts) =
-      SChoice qsn rdm y t <$> traverse go ts
-    go (GoalChoice rdm ts) =
-      GoalChoice rdm <$> traverse go ts
-    go x@(Fail _ _) = return x
-    go x@(Done _ _) = return x
-
-    -- The check proper
-    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
-    goP qpn@(Q _ pn) (POption i linkedTo) r = do
-      let inst = PI pn i
-      env <- ask
-      case (linkedTo, M.lookup inst env) of
-        (Just _, _) ->
-          -- For linked nodes we don't check anything
-          r
-        (Nothing, Nothing) ->
-          -- Not linked, not already used
-          local (M.insert inst qpn) r
-        (Nothing, Just qpn') -> do
-          -- Not linked, already used. This is an error
-          return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances
+-- -- | Monad used internally in enforceSingleInstanceRestriction
+-- --
+-- -- For each package instance we record the goal for which we picked a concrete
+-- -- instance. The SIR means that for any package instance there can only be one.
+-- type EnforceSIR = Reader (Map (PI PN) QPN)
+
+-- -- | Enforce ghc's single instance restriction
+-- --
+-- -- From the solver's perspective, this means that for any package instance
+-- -- (that is, package name + package version) there can be at most one qualified
+-- -- goal resolving to that instance (there may be other goals _linking_ to that
+-- -- instance however).
+-- enforceSingleInstanceRestriction :: Tree d c -> Tree d c
+-- enforceSingleInstanceRestriction = (`runReader` M.empty) . go
+--   where
+--     go :: Tree d c -> EnforceSIR (Tree d c)
+
+--     -- We just verify package choices.
+--     go (PChoice qpn rdm gr cs) =
+--       PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) (fmap go cs))
+--     go (FChoice qfn rdm y t m d ts) =
+--       FChoice qfn rdm y t m d <$> traverse go ts
+--     go (SChoice qsn rdm y t ts) =
+--       SChoice qsn rdm y t <$> traverse go ts
+--     go (GoalChoice rdm ts) =
+--       GoalChoice rdm <$> traverse go ts
+--     go x@(Fail _ _) = return x
+--     go x@(Done _ _) = return x
+
+--     -- The check proper
+--     goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
+--     goP qpn@(Q _ pn) (POption i linkedTo) r = do
+--       let inst = PI pn i
+--       env <- ask
+--       case (linkedTo, M.lookup inst env) of
+--         (Just _, _) ->
+--           -- For linked nodes we don't check anything
+--           r
+--         (Nothing, Nothing) ->
+--           -- Not linked, not already used
+--           local (M.insert inst qpn) r
+--         (Nothing, Just qpn') -> do
+--           -- Not linked, already used. This is an error
+--           return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances