Skip to content

Commit c276a47

Browse files
andreabediniandreabedini
committed
troubleshoot
1 parent ed4454e commit c276a47

File tree

3 files changed

+116
-174
lines changed

3 files changed

+116
-174
lines changed

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

Lines changed: 58 additions & 80 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
-- Top level interface to dependency resolution.
1717
{-# LANGUAGE LambdaCase #-}
1818
{-# LANGUAGE FlexibleContexts #-}
19+
{-# LANGUAGE NamedFieldPuns #-}
1920
module Distribution.Client.Dependency
2021
( -- * The main package dependency resolver
2122
DepResolverParams
@@ -73,7 +74,7 @@ import Distribution.Client.Compat.Prelude
7374
import Distribution.Client.Dependency.Types
7475
( PackagesPreferenceDefault (..)
7576
)
76-
import Distribution.Client.SolverInstallPlan (SolverInstallPlan, SolverPlanIndex)
77+
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
7778
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
7879
import Distribution.Client.Types
7980
( AllowNewer (..)
@@ -141,6 +142,7 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD
141142
import Distribution.Solver.Types.ConstraintSource
142143
import Distribution.Solver.Types.DependencyResolver
143144
import Distribution.Solver.Types.InstalledPreference as Preference
145+
import Distribution.Solver.Types.InstSolverPackage (InstSolverPackage(..))
144146
import Distribution.Solver.Types.LabeledPackageConstraint
145147
import Distribution.Solver.Types.OptionalStanza
146148
import Distribution.Solver.Types.PackageConstraint
@@ -166,7 +168,6 @@ import Data.List
166168
import qualified Data.Map as Map
167169
import qualified Data.Set as Set
168170
import Text.PrettyPrint hiding ((<>))
169-
import Data.Maybe (fromJust)
170171
import GHC.Stack (HasCallStack)
171172
import qualified Data.Tree
172173
import qualified Data.Graph
@@ -787,6 +788,46 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = do
787788
preferences
788789
constraints
789790
targets
791+
792+
step $ render $ vcat
793+
[ text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
794+
, text "Solver plan"
795+
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
796+
]
797+
for_ pkgs $ \pkg -> do
798+
step $ render $
799+
hang (pretty (solverQPN pkg) <+> text "->" <+> pretty (solverId pkg)) 4 $ case pkg of
800+
PreExisting InstSolverPackage{instSolverPkgExeDeps, instSolverPkgLibDeps} ->
801+
vcat
802+
[ hang (pretty comp) 2 $ vcat
803+
[ vcat [ hang (text "lib-deps:") 2 (vcat (map pretty libDeps)) | not (null libDeps) ]
804+
, vcat [ hang (text "exe-deps:") 2 (vcat (map pretty exeDeps)) | not (null exeDeps) ]
805+
]
806+
| (comp, (libDeps, exeDeps)) <- CD.toList (CD.zip instSolverPkgLibDeps instSolverPkgExeDeps)
807+
]
808+
Configured SolverPackage{solverPkgExeDeps, solverPkgLibDeps} ->
809+
vcat
810+
[ hang (pretty comp) 2 $ vcat
811+
[ vcat [ hang (text "lib-deps:") 2 (vcat (map pretty libDeps)) | not (null libDeps) ]
812+
, vcat [ hang (text "exe-deps:") 2 (vcat (map pretty exeDeps)) | not (null exeDeps) ]
813+
]
814+
| (comp, (libDeps, exeDeps)) <- CD.toList (CD.zip solverPkgLibDeps solverPkgExeDeps)
815+
]
816+
817+
step $ render $ vcat
818+
[ text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
819+
, text "Scopes"
820+
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
821+
, renderSolverPlanScopes pkgs
822+
]
823+
824+
step $ render $ vcat
825+
[ text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
826+
, text "Dependency tree"
827+
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
828+
, renderSolverPlanTree pkgs
829+
]
830+
790831
validateSolverResult toolchains pkgs
791832
where
792833
installedPkgIndex' = Staged $ \case
@@ -838,93 +879,30 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = do
838879
preferences :: PackageName -> PackagePreferences
839880
preferences = interpretPackagesPreference targets defpref prefs
840881

841-
dumpResolverPackageIndex :: HasCallStack => [ResolverPackage UnresolvedPkgLoc] -> Doc
842-
dumpResolverPackageIndex pkgs =
843-
vcat
844-
[
845-
text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
846-
, text "Solver results"
847-
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
848-
, vcat
849-
[ text "-" <+> nest 2 (dumpResolverPackage pkg)
850-
| pkg <- pkgs
851-
]
852-
-- text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
853-
-- , text "Library roots"
854-
-- , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
855-
-- , vcat
856-
-- [ text "-" <+> pretty root
857-
-- | root <- SolverInstallPlan.libraryRoots g
858-
-- ]
859-
-- , hang (text "closure") 4 $
860-
-- vcat $ map (pretty . Graph.nodeKey) $ fromJust $ Graph.closure g $ SolverInstallPlan.libraryRoots g
861-
-- , hang (text "nonSetupClosure") 4 $
862-
-- vcat $ map (pretty . Graph.nodeKey) $ Graph.toList $ SolverInstallPlan.nonSetupClosure g $ SolverInstallPlan.libraryRoots g
863-
-- , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
864-
-- , text "Setup roots"
865-
-- , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
866-
-- , vcat
867-
-- [ hang (pretty i <> text ".") 4 $ vcat
868-
-- [ hang (text "roots:") 4 $
869-
-- vcat $ map pretty rootset'
870-
-- , hang (text "closure:") 4 $
871-
-- vcat $ map (pretty . Graph.nodeKey) $ fromJust $ Graph.closure g rootset'
872-
-- , hang (text "nonSetupClosure:") 4 $
873-
-- vcat $ map (pretty . Graph.nodeKey) $ Graph.toList $ SolverInstallPlan.nonSetupClosure g rootset'
874-
-- ]
875-
-- | (i, rootset) <- zip [1::Int ..] (SolverInstallPlan.setupRoots g)
876-
-- , let rootset' = sort rootset
877-
-- ]
878-
-- , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
879-
-- , text "Scopes"
880-
-- , text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
881-
-- , vcat [ (pretty pp <+> text "/") $+$ nest 4 (vcat (map pretty (Set.toList sids)))
882-
-- | (pp, sids) <- Map.toList (qualifications g)
883-
-- ]
884-
-- , vcat [ hang (pretty key) 4 (vcat [ text "-" <+> pretty n | n <- neigh]) | (_pkg, key, neigh) <- edges ]
885-
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
886-
, text "Dependency tree"
887-
, text "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
888-
, text (Data.Tree.drawForest dfs)
882+
renderSolverPlanScopes :: [SolverInstallPlan.SolverPlanPackage] -> Doc
883+
renderSolverPlanScopes pkgs = vcat
884+
[ vcat [ (pretty pp <+> text "/") $+$ nest 4 (vcat (map pretty (Set.toList sids)))
885+
| (pp, sids) <- Map.toList (SolverInstallPlan.qualifications g)
886+
]
887+
-- , vcat [ hang (pretty key) 4 (vcat [ text "-" <+> pretty n | n <- neigh]) | (_pkg, key, neigh) <- mapG ]
889888
]
890-
-- ]
891889
where
892-
g :: SolverPlanIndex
893890
g = Graph.fromDistinctList pkgs
891+
-- (_g', mapG, _invG) = Data.Graph.graphFromEdges [ (pkg, Graph.nodeKey pkg, Graph.nodeNeighbors pkg) | pkg <- pkgs]
894892

895-
(graphForward, graphVertexToNode, graphKeyToVertex) = Graph.toGraph g
896893

894+
renderSolverPlanTree :: HasCallStack => [SolverInstallPlan.SolverPlanPackage] -> Doc
895+
renderSolverPlanTree pkgs = text (Data.Tree.drawForest dfs)
896+
where
897+
g = Graph.fromDistinctList pkgs
898+
899+
(graphForward, graphVertexToNode, graphKeyToVertex) = Graph.toGraph g
900+
897901
dfs = fmap (fmap (prettyShow . solverId . graphVertexToNode)) $ Data.Graph.dfs graphForward roots
902+
898903
Just roots = traverse graphKeyToVertex $ concat $ SolverInstallPlan.libraryRoots g : SolverInstallPlan.setupRoots g
899904

900905

901-
dumpNodes :: SolverPlanIndex -> Doc
902-
dumpNodes solverPlanIndex = vcat
903-
[ hang (pretty node) 4 $
904-
vcat [ hang (text "deps:") 4 $ vcat
905-
[ pretty depid <+> (if solverStage node /= solverStage depid then text "WRONG" else mempty)
906-
| depid <- map Graph.nodeKey deps
907-
]
908-
| let deps = fromJust (Graph.neighbors solverPlanIndex node)
909-
, not (null deps)
910-
]
911-
$$
912-
vcat [ hang (text "reverse-deps:") 4 $
913-
vcat [ pretty rdepid <+> (if solverStage node /= solverStage rdepid then text "WRONG" else mempty)
914-
| rdepid <- map Graph.nodeKey rdeps
915-
]
916-
| let rdeps = fromJust (Graph.revNeighbors solverPlanIndex node)
917-
, not (null rdeps)
918-
]
919-
| node <- Graph.keys solverPlanIndex
920-
]
921-
922-
drawForest :: Pretty a => [Data.Graph.Tree a] -> Doc
923-
drawForest = vcat . map drawTree
924-
925-
drawTree :: Pretty a => Data.Graph.Tree a -> Doc
926-
drawTree (Data.Graph.Node a ts0) = vcat [pretty a, nest 4 (vcat (map drawTree ts0))]
927-
928906
-- | Give an interpretation to the global 'PackagesPreference' as
929907
-- specific per-package 'PackageVersionPreference'.
930908
interpretPackagesPreference

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

Lines changed: 50 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
{-# LANGUAGE ScopedTypeVariables #-}
66
{-# LANGUAGE ViewPatterns #-}
77
{-# LANGUAGE FlexibleContexts #-}
8+
{-# LANGUAGE LambdaCase #-}
89

910
-- | This module deals with building and incrementally rebuilding a collection
1011
-- of packages. It is what backs the @cabal build@ and @configure@ commands,
@@ -1185,38 +1186,23 @@ dieOnBuildFailures
11851186
-> IO ()
11861187
dieOnBuildFailures verbosity currentCommand plan buildOutcomes
11871188
| null failures = return ()
1188-
| isSimpleCase = exitFailure
1189+
-- | isSimpleCase = exitFailure
11891190
| otherwise = do
1190-
-- For failures where we have a build log, print the log plus a header
1191-
sequence_
1192-
[ do
1191+
for_ failuresClassification $ \case
1192+
-- For failures where we have a build log, print the log plus a header
1193+
(pkg, ShowBuildSummaryAndLog reason logfile) -> do
11931194
notice verbosity $
11941195
'\n'
1195-
: renderFailureDetail False pkg reason
1196+
: renderFailureDetail True pkg reason
11961197
++ "\nBuild log ( "
11971198
++ logfile
11981199
++ " ):"
11991200
readFile logfile >>= noticeNoWrap verbosity
1200-
| (pkg, ShowBuildSummaryAndLog reason logfile) <-
1201-
failuresClassification
1202-
]
1203-
1204-
-- For all failures, print either a short summary (if we showed the
1205-
-- build log) or all details
1206-
dieIfNotHaddockFailure verbosity $
1207-
unlines
1208-
[ case failureClassification of
1209-
ShowBuildSummaryAndLog reason _
1210-
| verbosity > normal ->
1211-
renderFailureDetail mentionDepOf pkg reason
1212-
| otherwise ->
1213-
renderFailureSummary mentionDepOf pkg reason
1214-
++ ". See the build log above for details."
1215-
ShowBuildSummaryOnly reason ->
1216-
renderFailureDetail mentionDepOf pkg reason
1217-
| let mentionDepOf = verbosity <= normal
1218-
, (pkg, failureClassification) <- failuresClassification
1219-
]
1201+
-- For all failures, print either a short summary (if we showed the
1202+
-- build log) or all details
1203+
(pkg, ShowBuildSummaryOnly reason) ->
1204+
dieIfNotHaddockFailure verbosity $
1205+
renderFailureDetail True pkg reason
12201206
where
12211207
failures :: [(Graph.Key ElaboratedPlanPackage, BuildFailure)]
12221208
failures =
@@ -1263,45 +1249,45 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
12631249
ExitFailure 1 <- fromException e
12641250
return logfile
12651251

1266-
-- Special case: we don't want to report anything complicated in the case
1267-
-- of just doing build on the current package, since it's clear from
1268-
-- context which package failed.
1269-
--
1270-
-- We generalise this rule as follows:
1271-
-- - if only one failure occurs, and it is in a single root
1272-
-- package (i.e. a package with nothing else depending on it)
1273-
-- - and that failure is of a kind that always reports enough
1274-
-- detail itself (e.g. ghc reporting errors on stdout)
1275-
-- - then we do not report additional error detail or context.
1276-
--
1277-
isSimpleCase :: Bool
1278-
isSimpleCase
1279-
| [(WithStage s pkgid, failure)] <- failures
1280-
, [pkg] <- rootpkgs
1281-
, installedUnitId pkg == pkgid
1282-
, stageOf pkg == s
1283-
, isFailureSelfExplanatory (buildFailureReason failure)
1284-
, currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] =
1285-
True
1286-
| otherwise =
1287-
False
1288-
1289-
-- NB: if the Setup script segfaulted or was interrupted,
1290-
-- we should give more detailed information. So only
1291-
-- assume that exit code 1 is "pedestrian failure."
1292-
isFailureSelfExplanatory :: BuildFailureReason -> Bool
1293-
isFailureSelfExplanatory (BuildFailed e)
1294-
| Just (ExitFailure 1) <- fromException e = True
1295-
isFailureSelfExplanatory (ConfigureFailed e)
1296-
| Just (ExitFailure 1) <- fromException e = True
1297-
isFailureSelfExplanatory _ = False
1298-
1299-
rootpkgs :: [ElaboratedConfiguredPackage]
1300-
rootpkgs =
1301-
[ pkg
1302-
| InstallPlan.Configured pkg <- InstallPlan.toList plan
1303-
, hasNoDependents pkg
1304-
]
1252+
-- -- Special case: we don't want to report anything complicated in the case
1253+
-- -- of just doing build on the current package, since it's clear from
1254+
-- -- context which package failed.
1255+
-- --
1256+
-- -- We generalise this rule as follows:
1257+
-- -- - if only one failure occurs, and it is in a single root
1258+
-- -- package (i.e. a package with nothing else depending on it)
1259+
-- -- - and that failure is of a kind that always reports enough
1260+
-- -- detail itself (e.g. ghc reporting errors on stdout)
1261+
-- -- - then we do not report additional error detail or context.
1262+
-- --
1263+
-- isSimpleCase :: Bool
1264+
-- isSimpleCase
1265+
-- | [(WithStage s pkgid, failure)] <- failures
1266+
-- , [pkg] <- rootpkgs
1267+
-- , installedUnitId pkg == pkgid
1268+
-- , stageOf pkg == s
1269+
-- , isFailureSelfExplanatory (buildFailureReason failure)
1270+
-- , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] =
1271+
-- True
1272+
-- | otherwise =
1273+
-- False
1274+
1275+
-- -- NB: if the Setup script segfaulted or was interrupted,
1276+
-- -- we should give more detailed information. So only
1277+
-- -- assume that exit code 1 is "pedestrian failure."
1278+
-- isFailureSelfExplanatory :: BuildFailureReason -> Bool
1279+
-- isFailureSelfExplanatory (BuildFailed e)
1280+
-- | Just (ExitFailure 1) <- fromException e = True
1281+
-- isFailureSelfExplanatory (ConfigureFailed e)
1282+
-- | Just (ExitFailure 1) <- fromException e = True
1283+
-- isFailureSelfExplanatory _ = False
1284+
1285+
-- rootpkgs :: [ElaboratedConfiguredPackage]
1286+
-- rootpkgs =
1287+
-- [ pkg
1288+
-- | InstallPlan.Configured pkg <- InstallPlan.toList plan
1289+
-- , hasNoDependents pkg
1290+
-- ]
13051291

13061292
ultimateDeps :: (WithStage UnitId) -> [ElaboratedPlanPackage]
13071293
ultimateDeps pkgid@(WithStage s uid) =

0 commit comments

Comments
 (0)