packages feed

cabal-install 3.6.2.0 → 3.8.1.0

raw patch · 188 files changed

+21626/−11219 lines, 188 filesdep +Cabal-QuickCheckdep +Cabal-describeddep +Cabal-syntaxdep −deepseqdep −faildep −semigroupsdep ~Cabaldep ~Win32dep ~arraynew-uploader

Dependencies added: Cabal-QuickCheck, Cabal-described, Cabal-syntax, Cabal-tree-diff, QuickCheck, cabal-install, cabal-install-solver, exceptions, pretty-show, safe-exceptions, tagged, tasty, tasty-expected-failure, tasty-golden, tasty-hunit, tasty-quickcheck, tree-diff

Dependencies removed: deepseq, fail, semigroups, tracetree, transformers

Dependency ranges changed: Cabal, Win32, array, base, bytestring, containers, directory, filepath, hackage-security, hashable, mtl, network-uri, process, random, resolv, tar, text, time, zlib

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2003-2020, Cabal Development Team.+Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.
README.md view
@@ -4,10 +4,9 @@ See the [Cabal web site] for more information.  The `cabal-install` package provides a command line tool named `cabal`.-It uses the [Cabal] library and provides a user interface to the-Cabal/[Hackage] build automation and package management system. It can+It uses the Cabal library and provides a user interface to the+Cabal/Hackage build automation and package management system. It can build and install both local and remote packages, including dependencies.  [Cabal web site]: http://www.haskell.org/cabal/-[Cabal]: ../Cabal/README.md
− cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Utils.Assertion (expensiveAssert) where---#ifdef DEBUG_EXPENSIVE_ASSERTIONS-import Prelude (Bool)-import Control.Exception (assert)-import Distribution.Compat.Stack-#else-import Prelude (Bool, id)-#endif---- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This--- function can be used for expensive assertions that should only be turned on--- during testing or debugging.-#ifdef DEBUG_EXPENSIVE_ASSERTIONS-expensiveAssert :: WithCallStack (Bool -> a -> a)-expensiveAssert = assert-#else-expensiveAssert :: Bool -> a -> a-expensiveAssert _ = id-#endif
− cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs 
@@ -1,19 +0,0 @@--- to suppress WARNING in "Distribution.Compat.Prelude.Internal"-{-# OPTIONS_GHC -fno-warn-deprecations #-}---- | This module does two things:------ * Acts as a compatibility layer, like @base-compat@.------ * Provides commonly used imports.------ This module is a superset of "Distribution.Compat.Prelude" (which--- this module re-exports)----module Distribution.Solver.Compat.Prelude-  ( module Distribution.Compat.Prelude.Internal-  , Prelude.IO-  ) where--import Prelude (IO)-import Distribution.Compat.Prelude.Internal hiding (IO)
− cabal-install-solver/src/Distribution/Solver/Modular.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Distribution.Solver.Modular-         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where---- Here, we try to map between the external cabal-install solver--- interface and the internal interface that the solver actually--- expects. There are a number of type conversions to perform: we--- have to convert the package indices to the uniform index used--- by the solver; we also have to convert the initial constraints;--- and finally, we have to convert back the resulting install--- plan.--import Prelude ()-import Distribution.Solver.Compat.Prelude--import qualified Data.Map as M-import Data.Set (isSubsetOf)-import Distribution.Compat.Graph-         ( IsNode(..) )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.Solver.Modular.Assignment-         ( Assignment, toCPs )-import Distribution.Solver.Modular.ConfiguredConversion-         ( convCP )-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.IndexConversion-         ( convPIs )-import Distribution.Solver.Modular.Log-         ( SolverFailure(..), displayLogMessages )-import Distribution.Solver.Modular.Package-         ( PN )-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Solver-         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )-import Distribution.Solver.Types.DependencyResolver-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PkgConfigDb-         ( PkgConfigDb )-import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.Variable-import Distribution.System-         ( Platform(..) )-import Distribution.Simple.Setup-         ( BooleanFlag(..) )-import Distribution.Simple.Utils-         ( ordNubBy )-import Distribution.Verbosity----- | Ties the two worlds together: classic cabal-install vs. the modular--- solver. Performs the necessary translations before and after.-modularResolver :: SolverConfig -> DependencyResolver loc-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess) $ -- convert install plan-  solve' sc cinfo idx pkgConfigDB pprefs gcs pns-    where-      -- Indices have to be converted into solver-specific uniform index.-      idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx-      -- Constraints have to be converted into a finite map indexed by PN.-      gcs    = M.fromListWith (++) (map pair pcs)-        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---- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display--- in the error case.------ When there is no solution, we produce the error message by rerunning the--- solver but making it prefer the goals from the final conflict set from the--- first run (or a subset of the final conflict set with--- --minimize-conflict-set). We also set the backjump limit to 0, so that the--- log stops at the first backjump and is relatively short. Preferring goals--- from the final conflict set increases the probability that the log to the--- first backjump contains package, flag, and stanza choices that are relevant--- to the final failure. The solver shouldn't need to choose any packages that--- aren't in the final conflict set. (For every variable in the final conflict--- set, the final conflict set should also contain the variable that introduced--- that variable. The solver can then follow that chain of variables in reverse--- order from the user target to the conflict.) However, it is possible that the--- conflict set contains unnecessary variables.------ Producing an error message when the solver reaches the backjump limit is more--- complicated. There is no final conflict set, so we create one for the minimal--- subtree containing the path that the solver took to the first backjump. This--- conflict set helps explain why the solver reached the backjump limit, because--- the first backjump contributes to reaching the backjump limit. Additionally,--- the solver is much more likely to be able to finish traversing this subtree--- before the backjump limit, since its size is linear (not exponential) in the--- number of goal choices. We create it by pruning all children after the first--- successful child under each node in the original tree, so that there is at--- most one valid choice at each level. Then we use the final conflict set from--- that run to generate an error message, as in the case where the solver found--- that there was no solution.------ Using the full log from a rerun of the solver ensures that the log is--- complete, i.e., it shows the whole chain of dependencies from the user--- targets to the conflicting packages.-solve' :: SolverConfig-       -> CompilerInfo-       -> Index-       -> PkgConfigDb-       -> (PN -> PackagePreferences)-       -> Map PN [LabeledPackageConstraint]-       -> Set PN-       -> Progress String String (Assignment, RevDepMap)-solve' sc cinfo idx pkgConfigDB pprefs gcs pns =-    toProgress $ retry (runSolver printFullLog sc) createErrorMsg-  where-    runSolver :: Bool -> SolverConfig-              -> RetryLog String SolverFailure (Assignment, RevDepMap)-    runSolver keepLog sc' =-        displayLogMessages keepLog $-        solve sc' cinfo idx pkgConfigDB pprefs gcs pns--    createErrorMsg :: SolverFailure-                   -> RetryLog String String (Assignment, RevDepMap)-    createErrorMsg failure@(ExhaustiveSearch cs cm) =-      if asBool $ minimizeConflictSet sc-      then continueWith ("Found no solution after exhaustively searching the "-                          ++ "dependency tree. Rerunning the dependency solver "-                          ++ "to minimize the conflict set ({"-                          ++ showConflictSet cs ++ "}).") $-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $-               \case-                  ExhaustiveSearch cs' cm' ->-                      fromProgress $ Fail $-                          rerunSolverForErrorMsg cs'-                       ++ finalErrorMsg sc (ExhaustiveSearch cs' cm')-                  BackjumpLimitReached ->-                      fromProgress $ Fail $-                          "Reached backjump limit while trying to minimize the "-                       ++ "conflict set to create a better error message. "-                       ++ "Original error message:\n"-                       ++ rerunSolverForErrorMsg cs-                       ++ finalErrorMsg sc failure-      else fromProgress $ Fail $-           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure-    createErrorMsg failure@BackjumpLimitReached     =-        continueWith-             ("Backjump limit reached. Rerunning dependency solver to generate "-              ++ "a final conflict set for the search tree containing the "-              ++ "first backjump.") $-        retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $-            \case-               ExhaustiveSearch cs _ ->-                   fromProgress $ Fail $-                   rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure-               BackjumpLimitReached  ->-                   -- This case is possible when the number of goals involved in-                   -- conflicts is greater than the backjump limit.-                   fromProgress $ Fail $ finalErrorMsg sc failure-                    ++ "Failed to generate a summarized dependency solver "-                    ++ "log due to low backjump limit."--    rerunSolverForErrorMsg :: ConflictSet -> String-    rerunSolverForErrorMsg cs =-      let sc' = sc {-                    goalOrder = Just goalOrder'-                  , maxBackjumps = Just 0-                  }--          -- Preferring goals from the conflict set takes precedence over the-          -- original goal order.-          goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)--      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))--    printFullLog = solverVerbosity sc >= verbose--    messages :: Progress step fail done -> [step]-    messages = foldProgress (:) (const []) (const [])---- | Try to remove variables from the given conflict set to create a minimal--- conflict set.------ Minimal means that no proper subset of the conflict set is also a conflict--- set, though there may be other possible conflict sets with fewer variables.--- This function minimizes the input by trying to remove one variable at a time.--- It only makes one pass over the variables, so it runs the solver at most N--- times when given a conflict set of size N. Only one pass is necessary,--- because every superset of a conflict set is also a conflict set, meaning that--- failing to remove variable X from a conflict set in one step means that X--- cannot be removed from any subset of that conflict set in a subsequent step.------ Example steps:------ Start with {A, B, C}.--- Try to remove A from {A, B, C} and fail.--- Try to remove B from {A, B, C} and succeed.--- Try to remove C from {A, C} and fail.--- Return {A, C}------ This function can fail for two reasons:------ 1. The solver can reach the backjump limit on any run. In this case the---    returned RetryLog ends with BackjumpLimitReached.---    TODO: Consider applying the backjump limit to all solver runs combined,---    instead of each individual run. For example, 10 runs with 10 backjumps---    each should count as 100 backjumps.--- 2. Since this function works by rerunning the solver, it is possible for the---    solver to add new unnecessary variables to the conflict set. This function---    discards the result from any run that adds new variables to the conflict---    set, but the end result may not be completely minimized.-tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)-                         -> SolverConfig-                         -> ConflictSet-                         -> ConflictMap-                         -> RetryLog String SolverFailure a-tryToMinimizeConflictSet runSolver sc cs cm =-    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)-          (fromProgress $ Fail $ ExhaustiveSearch cs cm)-          (CS.toList cs)-  where-    -- This function runs the solver and makes it prefer goals in the following-    -- order:-    ---    -- 1. variables in 'smallestKnownCS', excluding 'v'-    -- 2. 'v'-    -- 3. all other variables-    ---    -- If 'v' is not necessary, then the solver will find that there is no-    -- solution before starting to solve for 'v', and the new final conflict set-    -- will be very likely to not contain 'v'. If 'v' is necessary, the solver-    -- will most likely need to try solving for 'v' before finding that there is-    -- no solution, and the new final conflict set will still contain 'v'.-    -- However, this method isn't perfect, because it is possible for the solver-    -- to add new unnecessary variables to the conflict set on any run. This-    -- function prevents the conflict set from growing by checking that the new-    -- conflict set is a subset of the old one and falling back to using the old-    -- conflict set when that check fails.-    tryToRemoveOneVar :: Var QPN-                      -> ConflictSet-                      -> ConflictMap-                      -> RetryLog String SolverFailure a-    tryToRemoveOneVar v smallestKnownCS smallestKnownCM-        -- Check whether v is still present, because it may have already been-        -- removed in a previous solver rerun.-      | not (v `CS.member` smallestKnownCS) =-          fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM-      | otherwise =-        continueWith ("Trying to remove variable " ++ varStr ++ " from the "-                      ++ "conflict set.") $-        retry (runSolver sc') $ \case-            err@(ExhaustiveSearch cs' _)-              | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->-                  let msg = if not $ CS.member v cs'-                            then "Successfully removed " ++ varStr ++ " from "-                                  ++ "the conflict set."-                            else "Failed to remove " ++ varStr ++ " from the "-                                  ++ "conflict set."-                  in -- Use the new conflict set, even if v wasn't removed,-                     -- because other variables may have been removed.-                     failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err-              | otherwise ->-                  failWith ("Failed to find a smaller conflict set. The new "-                             ++ "conflict set is not a subset of the previous "-                             ++ "conflict set: " ++ showCS cs') $-                  ExhaustiveSearch smallestKnownCS smallestKnownCM-            BackjumpLimitReached ->-                failWith ("Reached backjump limit while minimizing conflict set.")-                         BackjumpLimitReached-      where-        varStr = "\"" ++ showVar v ++ "\""-        showCS cs' = "{" ++ showConflictSet cs' ++ "}"--        sc' = sc { goalOrder = Just goalOrder' }--        goalOrder' =-            preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS)-         <> preferGoal v-         <> fromMaybe mempty (goalOrder sc)--    -- Like 'retry', except that it only applies the input function when the-    -- backjump limit has not been reached.-    retryNoSolution :: RetryLog step SolverFailure done-                    -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)-                    -> RetryLog step SolverFailure done-    retryNoSolution lg f = retry lg $ \case-        ExhaustiveSearch cs' cm' -> f cs' cm'-        BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)---- | Goal ordering that chooses goals contained in the conflict set before--- other goals.-preferGoalsFromConflictSet :: ConflictSet-                           -> Variable QPN -> Variable QPN -> Ordering-preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs---- | Goal ordering that chooses the given goal first.-preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering-preferGoal preferred = comparing $ \v -> toVar v /= preferred--toVar :: Variable QPN -> Var QPN-toVar (PackageVar qpn)    = P qpn-toVar (FlagVar    qpn fn) = F (FN qpn fn)-toVar (StanzaVar  qpn sn) = S (SN qpn sn)--finalErrorMsg :: SolverConfig -> SolverFailure -> String-finalErrorMsg sc failure =-    case failure of-      ExhaustiveSearch cs cm ->-          "After searching the rest of the dependency tree exhaustively, "-          ++ "these were the goals I've had most trouble fulfilling: "-          ++ showCS cm cs-          ++ flagSuggestion-        where-          showCS = if solverVerbosity sc > normal-                   then CS.showCSWithFrequency-                   else CS.showCSSortedByFrequency-          flagSuggestion =-              -- Don't suggest --minimize-conflict-set if the conflict set is-              -- already small, because it is unlikely to be reduced further.-              if CS.size cs > 3 && not (asBool (minimizeConflictSet sc))-              then "\nTry running with --minimize-conflict-set to improve the "-                    ++ "error message."-              else ""-      BackjumpLimitReached ->-          "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++-          "change with --max-backjumps or try to run with --reorder-goals).\n"-        where currlimit (Just n) = "currently " ++ show n ++ ", "-              currlimit Nothing  = ""
− cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs 
@@ -1,94 +0,0 @@-module Distribution.Solver.Modular.Assignment-    ( Assignment(..)-    , PAssignment-    , FAssignment-    , SAssignment-    , toCPs-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (pi)--import qualified Data.Array as A-import qualified Data.List as L-import qualified Data.Map as M--import Data.Maybe (fromJust)--import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal--import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)-import qualified Distribution.Solver.Types.ComponentDeps as CD-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath--import Distribution.Solver.Modular.Configured-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.LabeledGraph-import Distribution.Solver.Modular.Package---- | A (partial) package assignment. Qualified package names--- are associated with instances.-type PAssignment    = Map QPN I--type FAssignment    = Map QFN Bool-type SAssignment    = Map QSN Bool---- | A (partial) assignment of variables.-data Assignment = A PAssignment FAssignment SAssignment-  deriving (Show, Eq)---- | Delivers an ordered list of fully configured packages.------ TODO: This function is (sort of) ok. However, there's an open bug--- w.r.t. unqualification. There might be several different instances--- of one package version chosen by the solver, which will lead to--- clashes.-toCPs :: Assignment -> RevDepMap -> [CP QPN]-toCPs (A pa fa sa) rdm =-  let-    -- get hold of the graph-    g   :: Graph Component-    vm  :: Vertex -> ((), QPN, [(Component, QPN)])-    cvm :: QPN -> Maybe Vertex-    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.-    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))-                                  (M.toList rdm))-    tg :: Graph Component-    tg = transposeG g-    -- Topsort the dependency graph, yielding a list of pkgs in the right order.-    -- The graph will still contain all the installed packages, and it might-    -- contain duplicates, because several variables might actually resolve to-    -- the same package in the presence of qualified package names.-    ps :: [PI QPN]-    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $-         topSort g-    -- Determine the flags per package, by walking over and regrouping the-    -- complete flag assignment by package.-    fapp :: Map QPN FlagAssignment-    fapp = M.fromListWith mappend $-           L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $-           M.toList $-           fa-    -- Stanzas per package.-    sapp :: Map QPN OptionalStanzaSet-    sapp = M.fromListWith mappend-         $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))-         $ M.toList sa-    -- Dependencies per package.-    depp :: QPN -> [(Component, PI QPN)]-    depp qpn = let v :: Vertex-                   v   = fromJust (cvm qpn) -- TODO: why this is safe?-                   dvs :: [(Component, Vertex)]-                   dvs = tg A.! v-               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs-    -- Translated to PackageDeps-    depp' :: QPN -> ComponentDeps [PI QPN]-    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp-  in-    L.map (\ pi@(PI qpn _) -> CP pi-                                 (M.findWithDefault mempty qpn fapp)-                                 (M.findWithDefault mempty qpn sapp)-                                 (depp' qpn))-          ps
− cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs 
@@ -1,296 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.Builder (-    buildTree-  , splits -- for testing-  ) where---- Building the search tree.------ In this phase, we build a search tree that is too large, i.e, it contains--- invalid solutions. We keep track of the open goals at each point. We--- nondeterministically pick an open goal (via a goal choice node), create--- subtrees according to the index and the available solutions, and extend the--- set of open goals by superficially looking at the dependencies recorded in--- the index.------ For each goal, we keep track of all the *reasons* why it is being--- introduced. These are for debugging and error messages, mainly. A little bit--- of care has to be taken due to the way we treat flags. If a package has--- flag-guarded dependencies, we cannot introduce them immediately. Instead, we--- store the entire dependency.--import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.Set as S-import Prelude--import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.ComponentDeps-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Settings---- | All state needed to build and link the search tree. It has a type variable--- because the linking phase doesn't need to know about the state used to build--- the tree.-data Linker a = Linker {-  buildState   :: a,-  linkingState :: LinkingState-}---- | The state needed to build the search tree without creating any linked nodes.-data BuildState = BS {-  index :: Index,                   -- ^ information about packages and their dependencies-  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-  qualifyOptions :: QualifyOptions  -- ^ qualification options-}---- | Map of available linking targets.-type LinkingState = M.Map (PN, I) [PackagePath]---- | Extend the set of open goals with the new goals listed.------ We also adjust the map of overall goals, and keep track of the--- reverse dependencies of each of the goals.-extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState-extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs-  where-    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState-    go g o []                                             = s { rdeps = g, open = o }-    go g o ((Flagged fn@(FN qpn _) fInfo t f)  : ngs) =-        go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs-      -- Note: for 'Flagged' goals, we always insert, so later additions win.-      -- This is important, because in general, if a goal is inserted twice,-      -- the later addition will have better dependency information.-    go g o ((Stanza sn@(SN qpn _) t)           : ngs) =-        go g (StanzaGoal sn t (flagGR qpn) : o) ngs-    go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)-      | qpn == qpn'       =-            -- We currently only add a self-dependency to the graph if it is-            -- between a package and its setup script. The edge creates a cycle-            -- and causes the solver to backtrack and choose a different-            -- instance for the setup script. We may need to track other-            -- self-dependencies once we implement component-based solving.-          case c of-            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs-            _              -> go                                                    g  o ngs-      | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs-          -- code above is correct; insert/adjust have different arg order-    go g o ((Simple (LDep _dr (Ext _ext )) _)  : ngs) = go g o ngs-    go g o ((Simple (LDep _dr (Lang _lang))_)  : ngs) = go g o ngs-    go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs--    addIfAbsent :: Eq a => a -> [a] -> [a]-    addIfAbsent x xs = if x `elem` xs then xs else x : xs--    -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by-    -- its containing package.-    flagGR :: qpn -> GoalReason qpn-    flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)---- | Given the current scope, qualify all the package names in the given set of--- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->-                    BuildState -> BuildState-scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s-  where-    -- Qualify all package names-    qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps-    -- Introduce all package flags-    qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs-    -- Combine new package and flag goals-    gs     = qfdefs ++ qfdeps-    -- NOTE:-    ---    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially-    -- multiple times, both via the flag declaration and via dependencies.---- | Datatype that encodes what to build next-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--build :: Linker BuildState -> Tree () QGoalReason-build = ana go-  where-    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)-    go s = addLinking (linkingState s) $ addChildren (buildState s)--addChildren :: BuildState -> TreeF () QGoalReason BuildState---- If we have a choice between many goals, we just record the choice in--- the tree. We select each open goal in turn, and before we descend, remove--- it from the queue of open goals.-addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })-  | L.null gs = DoneF rdm ()-  | otherwise = GoalChoiceF rdm $ P.fromList-                                $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))-                                $ splits gs---- If we have already picked a goal, then the choice depends on the kind--- of goal.------ For a package, we look up the instances available in the global info,--- and then handle each instance in turn.-addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =-  case M.lookup pn idx of-    Nothing  -> FailF-                (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)-                UnknownPackage-    Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->-                                                       ([], POption i Nothing, bs { next = Instance qpn info }))-                                                     (M.toList pis)))-      -- TODO: data structure conversion is rather ugly here---- For a flag, we create only two subtrees, and we create them in the order--- that is indicated by the flag default.-addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =-  FChoiceF qfn rdm gr weak m b (W.fromList-    [([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals }),-     ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])-  where-    trivial = L.null t && L.null f-    weak = WeakOrTrivial $ unWeakOrTrivial w || trivial---- For a stanza, we also create only two subtrees. The order is initially--- False, True. This can be changed later by constraints (force enabling--- the stanza by replacing the False branch with failure) or preferences--- (try enabling the stanza if possible by moving the True branch first).--addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =-  SChoiceF qsn rdm gr trivial (W.fromList-    [([0], False,                                                                  bs  { next = Goals }),-     ([1], True,  (extendOpen qpn t bs) { next = Goals })])-  where-    trivial = WeakOrTrivial (L.null t)---- For a particular instance, we change the state: we update the scope,--- and furthermore we update the set of goals.------ TODO: We could inline this above.-addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =-  addChildren ((scopedExtendOpen qpn fdeps fdefs bs)-         { next = Goals })--{--------------------------------------------------------------------------------  Add linking--------------------------------------------------------------------------------}---- | Introduce link nodes into the tree------ Linking is a phase that adapts package choice nodes and adds the option to--- link wherever appropriate: Package goals are called "related" if they are for--- the same instance of the same package (but have different prefixes). A link--- option is available in a package choice node whenever we can choose an--- instance that has already been chosen for a related goal at a higher position--- in the tree. We only create link options for related goals that are not--- themselves linked, because the choice to link to a linked goal is the same as--- the choice to link to the target of that goal's linking.------ The code here proceeds by maintaining a finite map recording choices that--- have been made at higher positions in the tree. For each pair of package name--- and instance, it stores the prefixes at which we have made a choice for this--- package instance. Whenever we make an unlinked choice, we extend the map.--- Whenever we find a choice, we look into the map in order to find out what--- link options we have to add.------ A separate tree traversal would be simpler. However, 'addLinking' creates--- linked nodes from existing unlinked nodes, which leads to sharing between the--- nodes. If we copied the nodes when they were full trees of type--- 'Tree () QGoalReason', then the sharing would cause a space leak during--- exploration of the tree. Instead, we only copy the 'BuildState', which is--- relatively small, while the tree is being constructed. See--- https://github.com/haskell/cabal/issues/2899-addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)--- The only nodes of interest are package nodes-addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =-  let linkedCs = fmap (\bs -> Linker bs ls) $-                 W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)-      unlinkedCs = W.mapWithKey goP cs-      allCs = unlinkedCs `W.union` linkedCs--      -- Recurse underneath package choices. Here we just need to make sure-      -- that we record the package choice so that it is available below-      goP :: POption -> a -> Linker a-      goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls-      goP _                   _  = alreadyLinked-  in PChoiceF qpn rdm gr allCs-addLinking ls t = fmap (\bs -> Linker bs ls) t--linkChoices :: forall a w . LinkingState-            -> QPN-            -> (w, POption, a)-            -> [(w, POption, a)]-linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =-    L.map aux (M.findWithDefault [] (pn, i) related)-  where-    aux :: PackagePath -> (w, POption, a)-    aux pp = (weight, POption i (Just pp), subtree)-linkChoices _ _ (_, POption _ (Just _), _) =-    alreadyLinked--alreadyLinked :: a-alreadyLinked = error "addLinking called on tree that already contains linked nodes"------------------------------------------------------------------------------------- | Interface to the tree builder. Just takes an index and a list of package names,--- and computes the initial state and then the tree from there.-buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason-buildTree idx (IndependentGoals ind) igs =-    build Linker {-        buildState = BS {-            index = idx-          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)-          , open  = L.map topLevelGoal qpns-          , next  = Goals-          , qualifyOptions = defaultQualifyOptions idx-          }-      , linkingState = M.empty-      }-  where-    topLevelGoal qpn = PkgGoal qpn UserGoal--    qpns | ind       = L.map makeIndependent igs-         | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs--{--------------------------------------------------------------------------------  Goals--------------------------------------------------------------------------------}---- | Information needed about a dependency before it is converted into a Goal.-data OpenGoal =-    FlagGoal   (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason-  | StanzaGoal (SN QPN)       (FlaggedDeps QPN)                   QGoalReason-  | PkgGoal    QPN                                                QGoalReason---- | Closes a goal, i.e., removes all the extraneous information that we--- need only during the build phase.-close :: OpenGoal -> Goal QPN-close (FlagGoal   qfn _ _ _ gr) = Goal (F qfn) gr-close (StanzaGoal qsn _     gr) = Goal (S qsn) gr-close (PkgGoal    qpn       gr) = Goal (P qpn) gr--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}---- | Pairs each element of a list with the list resulting from removal of that--- element from the original list.-splits :: [a] -> [(a, [a])]-splits = go id-  where-    go :: ([a] -> [a]) -> [a] -> [(a, [a])]-    go _ [] = []-    go f (x : xs) = (x, f xs) : go (f . (x :)) xs
− cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs 
@@ -1,13 +0,0 @@-module Distribution.Solver.Modular.Configured-    ( CP(..)-    ) where--import Distribution.PackageDescription (FlagAssignment)--import Distribution.Solver.Modular.Package-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import Distribution.Solver.Types.OptionalStanza---- | A configured package is a package instance together with--- a flag assignment and complete dependencies.-data CP qpn = CP (PI qpn) FlagAssignment OptionalStanzaSet (ComponentDeps [PI qpn])
− cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs 
@@ -1,72 +0,0 @@-module Distribution.Solver.Modular.ConfiguredConversion-    ( convCP-    ) where--import Data.Maybe-import Prelude hiding (pi)-import Data.Either (partitionEithers)--import Distribution.Package (UnitId, packageId)--import qualified Distribution.Simple.PackageIndex as SI--import Distribution.Solver.Modular.Configured-import Distribution.Solver.Modular.Package--import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import qualified Distribution.Solver.Types.PackageIndex as CI-import           Distribution.Solver.Types.PackagePath-import           Distribution.Solver.Types.ResolverPackage-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.SolverPackage-import           Distribution.Solver.Types.InstSolverPackage-import           Distribution.Solver.Types.SourcePackage---- | Converts from the solver specific result @CP QPN@ into--- a 'ResolverPackage', which can then be converted into--- the install plan.-convCP :: SI.InstalledPackageIndex ->-          CI.PackageIndex (SourcePackage loc) ->-          CP QPN -> ResolverPackage loc-convCP iidx sidx (CP qpi fa es ds) =-  case convPI qpi of-    Left  pi -> PreExisting $-                  InstSolverPackage {-                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,-                    instSolverPkgLibDeps = fmap fst ds',-                    instSolverPkgExeDeps = fmap snd ds'-                  }-    Right pi -> Configured $-                  SolverPackage {-                      solverPkgSource = srcpkg,-                      solverPkgFlags = fa,-                      solverPkgStanzas = es,-                      solverPkgLibDeps = fmap fst ds',-                      solverPkgExeDeps = fmap snd ds'-                    }-      where-        srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi-  where-    ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})-    ds' = fmap (partitionEithers . map convConfId) ds--convPI :: PI QPN -> Either UnitId PackageId-convPI (PI _ (I _ (Inst pi))) = Left pi-convPI pi                     = Right (packageId (either id id (convConfId pi)))--convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}-convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =-    case loc of-        Inst pi -> Left (PreExistingId sourceId pi)-        _otherwise-          | QualExe _ pn' <- q-          -- NB: the dependencies of the executable are also-          -- qualified.  So the way to tell if this is an executable-          -- dependency is to make sure the qualifier is pointing-          -- at the actual thing.  Fortunately for us, I was-          -- silly and didn't allow arbitrarily nested build-tools-          -- dependencies, so a shallow check works.-          , pn == pn' -> Right (PlannedId sourceId)-          | otherwise    -> Left  (PlannedId sourceId)-  where-    sourceId    = PackageIdentifier pn v
− cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif--- | Conflict sets------ Intended for double import------ > import Distribution.Solver.Modular.ConflictSet (ConflictSet)--- > import qualified Distribution.Solver.Modular.ConflictSet as CS-module Distribution.Solver.Modular.ConflictSet (-    ConflictSet -- opaque-  , Conflict(..)-  , ConflictMap-  , OrderedVersionRange(..)-#ifdef DEBUG_CONFLICT_SETS-  , conflictSetOrigin-#endif-  , showConflictSet-  , showCSSortedByFrequency-  , showCSWithFrequency-    -- Set-like operations-  , toSet-  , toList-  , union-  , unions-  , insert-  , delete-  , empty-  , singleton-  , singletonWithConflict-  , size-  , member-  , lookup-  , filter-  , fromList-  ) where--import Prelude hiding (lookup)-import Data.List (intercalate, sortBy)-import Data.Map (Map)-import Data.Set (Set)-import Data.Function (on)-import qualified Data.Map.Strict as M-import qualified Data.Set as S--#ifdef DEBUG_CONFLICT_SETS-import Data.Tree-import GHC.Stack-#endif--import Distribution.Solver.Modular.Var-import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.PackagePath---- | The set of variables involved in a solver conflict, each paired with--- details about the conflict.-data ConflictSet = CS {-    -- | The set of variables involved in the conflict-    conflictSetToMap :: !(Map (Var QPN) (Set Conflict))--#ifdef DEBUG_CONFLICT_SETS-    -- | The origin of the conflict set-    ---    -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,-    -- we record the origin of every conflict set. For new conflict sets-    -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations-    -- that construct new conflict sets from existing conflict sets ('union',-    -- 'filter', ..)  we record the 'CallStack' to the call to the combinator-    -- as well as the 'CallStack's of the input conflict sets.-    ---    -- Requires @GHC >= 7.10@.-  , conflictSetOrigin :: Tree CallStack-#endif-  }-  deriving (Show)---- | More detailed information about how a conflict set variable caused a--- conflict. This information can be used to determine whether a second value--- for that variable would lead to the same conflict.------ TODO: Handle dependencies under flags or stanzas.-data Conflict =--    -- | The conflict set variable represents a package which depends on the-    -- specified problematic package. For example, the conflict set entry-    -- '(P x, GoalConflict y)' means that package x introduced package y, and y-    -- led to a conflict.-    GoalConflict QPN--    -- | The conflict set variable represents a package with a constraint that-    -- excluded the specified package and version. For example, the conflict set-    -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that-    -- package x's constraint on y excluded y-2.0.-  | VersionConstraintConflict QPN Ver--    -- | The conflict set variable represents a package that was excluded by a-    -- constraint from the specified package. For example, the conflict set-    -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))'-    -- means that package y's constraint 'x >= 2.0' excluded some version of x.-  | VersionConflict QPN OrderedVersionRange--    -- | Any other conflict.-  | OtherConflict-  deriving (Eq, Ord, Show)---- | Version range with an 'Ord' instance.-newtype OrderedVersionRange = OrderedVersionRange VR-  deriving (Eq, Show)---- TODO: Avoid converting the version ranges to strings.-instance Ord OrderedVersionRange where-  compare = compare `on` show--instance Eq ConflictSet where-  (==) = (==) `on` conflictSetToMap--instance Ord ConflictSet where-  compare = compare `on` conflictSetToMap--showConflictSet :: ConflictSet -> String-showConflictSet = intercalate ", " . map showVar . toList--showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String-showCSSortedByFrequency = showCS False--showCSWithFrequency :: ConflictMap -> ConflictSet -> String-showCSWithFrequency = showCS True--showCS :: Bool -> ConflictMap -> ConflictSet -> String-showCS showCount cm =-    intercalate ", " . map showWithFrequency . indexByFrequency-  where-    indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList-    showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of-      Just frequency-        | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")"-      _             -> showVar conflict--{--------------------------------------------------------------------------------  Set-like operations--------------------------------------------------------------------------------}--toSet :: ConflictSet -> Set (Var QPN)-toSet = M.keysSet . conflictSetToMap--toList :: ConflictSet -> [Var QPN]-toList = M.keys . conflictSetToMap--union ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet -> ConflictSet -> ConflictSet-union cs cs' = CS {-      conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs')-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])-#endif-    }--unions ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [ConflictSet] -> ConflictSet-unions css = CS {-      conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin css)-#endif-    }--insert ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet -> ConflictSet-insert var cs = CS {-      conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]-#endif-    }--delete :: Var QPN -> ConflictSet -> ConflictSet-delete var cs = CS {-      conflictSetToMap = M.delete var (conflictSetToMap cs)-    }--empty ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet-empty = CS {-      conflictSetToMap = M.empty-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--singleton ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet-singleton var = singletonWithConflict var OtherConflict--singletonWithConflict ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> Conflict -> ConflictSet-singletonWithConflict var conflict = CS {-      conflictSetToMap = M.singleton var (S.singleton conflict)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--size :: ConflictSet -> Int-size = M.size . conflictSetToMap--member :: Var QPN -> ConflictSet -> Bool-member var = M.member var . conflictSetToMap--lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict)-lookup var = M.lookup var . conflictSetToMap--fromList ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [Var QPN] -> ConflictSet-fromList vars = CS {-      conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars]-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--type ConflictMap = Map (Var QPN) Int-
− cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Distribution.Solver.Modular.Cycles (-    detectCyclesPhase-  ) where--import Prelude hiding (cycle)-import qualified Data.Map as M-import qualified Data.Set as S--import qualified Distribution.Compat.Graph as G-import Distribution.Simple.Utils (ordNub)-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Types.ComponentDeps (Component)-import Distribution.Solver.Types.PackagePath---- | Find and reject any nodes with cyclic dependencies-detectCyclesPhase :: Tree d c -> Tree d c-detectCyclesPhase = cata go-  where-    -- Only check children of choice nodes.-    go :: TreeF d c (Tree d c) -> Tree d c-    go (PChoiceF qpn rdm gr                         cs) =-        PChoice qpn rdm gr     $ fmap (checkChild qpn)   cs-    go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =-        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs-    go (SChoiceF qsn@(SN qpn _) rdm gr w     cs) =-        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   cs-    go x                                                = inn x--    checkChild :: QPN -> Tree d c -> Tree d c-    checkChild qpn x@(PChoice _  rdm _       _) = failIfCycle qpn rdm x-    checkChild qpn x@(FChoice _  rdm _ _ _ _ _) = failIfCycle qpn rdm x-    checkChild qpn x@(SChoice _  rdm _ _     _) = failIfCycle qpn rdm x-    checkChild qpn x@(GoalChoice rdm         _) = failIfCycle qpn rdm x-    checkChild _   x@(Fail _ _)                 = x-    checkChild qpn x@(Done       rdm _)         = failIfCycle qpn rdm x--    failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c-    failIfCycle qpn rdm x =-      case findCycles qpn rdm of-        Nothing     -> x-        Just relSet -> Fail relSet CyclicDependencies---- | Given the reverse dependency map from a node in the tree, check--- if the solution is cyclic. If it is, return the conflict set containing--- all decisions that could potentially break the cycle.------ TODO: The conflict set should also contain flag and stanza variables.-findCycles :: QPN -> RevDepMap -> Maybe ConflictSet-findCycles pkg rdm =-    -- This function has two parts: a faster cycle check that is called at every-    -- step and a slower calculation of the conflict set.-    ---    -- 'hasCycle' checks for cycles incrementally by only looking for cycles-    -- containing the current package, 'pkg'. It searches for cycles in the-    -- 'RevDepMap', which is the data structure used to store reverse-    -- dependencies in the search tree. We store the reverse dependencies in a-    -- map, because Data.Map is smaller and/or has better sharing than-    -- Distribution.Compat.Graph.-    ---    -- If there is a cycle, we call G.cycles to find a strongly connected-    -- component. Then we choose one cycle from the component to use for the-    -- conflict set. Choosing only one cycle can lead to a smaller conflict set,-    -- such as when a choice to enable testing introduces many cycles at once.-    -- In that case, all cycles contain the current package and are in one large-    -- strongly connected component.-    ---    if hasCycle-    then let scc :: G.Graph RevDepMapNode-             scc = case G.cycles $ revDepMapToGraph rdm of-                     []    -> findCyclesError "cannot find a strongly connected component"-                     c : _ -> G.fromDistinctList c--             next :: QPN -> QPN-             next p = case G.neighbors scc p of-                        Just (n : _) -> G.nodeKey n-                        _            -> findCyclesError "cannot find next node in the cycle"--             -- This function also assumes that all cycles contain 'pkg'.-             oneCycle :: [QPN]-             oneCycle = case iterate next pkg of-                          []     -> findCyclesError "empty cycle"-                          x : xs -> x : takeWhile (/= x) xs-         in Just $ CS.fromList $ map P oneCycle-    else Nothing-  where-    hasCycle :: Bool-    hasCycle = pkg `S.member` closure (neighbors pkg)--    closure :: [QPN] -> S.Set QPN-    closure = foldl go S.empty-      where-        go :: S.Set QPN -> QPN -> S.Set QPN-        go s x =-            if x `S.member` s-            then s-            else foldl go (S.insert x s) $ neighbors x--    neighbors :: QPN -> [QPN]-    neighbors x = case x `M.lookup` rdm of-                    Nothing -> findCyclesError "cannot find node"-                    Just xs -> map snd xs--    findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++)--data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]--instance G.IsNode RevDepMapNode where-  type Key RevDepMapNode = QPN-  nodeKey (RevDepMapNode qpn _) = qpn-  nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns--revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode-revDepMapToGraph rdm = G.fromDistinctList-                       [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]
− cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs 
@@ -1,358 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-module Distribution.Solver.Modular.Dependency (-    -- * Variables-    Var(..)-  , showVar-  , varPN-    -- * Conflict sets-  , ConflictSet-  , ConflictMap-  , CS.showConflictSet-    -- * Constrained instances-  , CI(..)-    -- * Flagged dependencies-  , FlaggedDeps-  , FlaggedDep(..)-  , LDep(..)-  , Dep(..)-  , PkgComponent(..)-  , ExposedComponent(..)-  , DependencyReason(..)-  , showDependencyReason-  , flattenFlaggedDeps-  , QualifyOptions(..)-  , qualifyDeps-  , unqualifyDeps-    -- * Reverse dependency map-  , RevDepMap-    -- * Goals-  , Goal(..)-  , GoalReason(..)-  , QGoalReason-  , goalToVar-  , varToConflictSet-  , goalReasonToConflictSet-  , goalReasonToConflictSetWithConflict-  , dependencyReasonToConflictSet-  , dependencyReasonToConflictSetWithVersionConstraintConflict-  , dependencyReasonToConflictSetWithVersionConflict-  ) where--import Prelude ()-import qualified Data.Map as M-import qualified Data.Set as S-import Distribution.Solver.Compat.Prelude hiding (pi)--import Language.Haskell.Extension (Extension(..), Language(..))--import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Var-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.ConflictSet as CS--import Distribution.Solver.Types.ComponentDeps (Component(..))-import Distribution.Solver.Types.PackagePath-import Distribution.Types.LibraryName-import Distribution.Types.PkgconfigVersionRange-import Distribution.Types.UnqualComponentName--{--------------------------------------------------------------------------------  Constrained instances--------------------------------------------------------------------------------}---- | Constrained instance. It represents the allowed instances for a package,--- which can be either a fixed instance or a version range.-data CI = Fixed I | Constrained VR-  deriving (Eq, Show)--{--------------------------------------------------------------------------------  Flagged dependencies--------------------------------------------------------------------------------}---- | Flagged dependencies------ 'FlaggedDeps' is the modular solver's view of a packages dependencies:--- rather than having the dependencies indexed by component, each dependency--- defines what component it is in.------ Note that each dependency is associated with a Component. We must know what--- component the dependencies belong to, or else we won't be able to construct--- fine-grained reverse dependencies.-type FlaggedDeps qpn = [FlaggedDep qpn]---- | Flagged dependencies can either be plain dependency constraints,--- or flag-dependent dependency trees.-data FlaggedDep qpn =-    -- | Dependencies which are conditional on a flag choice.-    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)-    -- | Dependencies which are conditional on whether or not a stanza-    -- (e.g., a test suite or benchmark) is enabled.-  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-    -- | Dependencies which are always enabled, for the component 'comp'.-  | Simple (LDep qpn) Component---- | Conversatively flatten out flagged dependencies------ NOTE: We do not filter out duplicates.-flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)]-flattenFlaggedDeps = concatMap aux-  where-    aux :: FlaggedDep qpn -> [(LDep qpn, Component)]-    aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f-    aux (Stanza  _   t)   = flattenFlaggedDeps t-    aux (Simple d c)      = [(d, c)]--type TrueFlaggedDeps  qpn = FlaggedDeps qpn-type FalseFlaggedDeps qpn = FlaggedDeps qpn---- | A 'Dep' labeled with the reason it was introduced.------ 'LDep' intentionally has no 'Functor' instance because the type variable--- is used both to record the dependencies as well as who's doing the--- depending; having a 'Functor' instance makes bugs where we don't distinguish--- these two far too likely. (By rights 'LDep' ought to have two type variables.)-data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)---- | A dependency (constraint) associates a package name with a constrained--- instance. It can also represent other types of dependencies, such as--- dependencies on language extensions.-data Dep qpn = Dep (PkgComponent qpn) CI  -- ^ dependency on a package component-             | Ext Extension              -- ^ dependency on a language extension-             | Lang Language              -- ^ dependency on a language version-             | Pkg PkgconfigName PkgconfigVersionRange  -- ^ dependency on a pkg-config package-  deriving Functor---- | An exposed component within a package. This type is used to represent--- build-depends and build-tool-depends dependencies.-data PkgComponent qpn = PkgComponent qpn ExposedComponent-  deriving (Eq, Ord, Functor, Show)---- | A component that can be depended upon by another package, i.e., a library--- or an executable.-data ExposedComponent =-    ExposedLib LibraryName-  | ExposedExe UnqualComponentName-  deriving (Eq, Ord, Show)---- | The reason that a dependency is active. It identifies the package and any--- flag and stanza choices that introduced the dependency. It contains--- everything needed for creating ConflictSets or describing conflicts in solver--- log messages.-data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)-  deriving (Functor, Eq, Show)---- | Print the reason that a dependency was introduced.-showDependencyReason :: DependencyReason QPN -> String-showDependencyReason (DependencyReason qpn flags stanzas) =-    intercalate " " $-        showQPN qpn-      : map (uncurry showFlagValue) (M.toList flags)-     ++ map (\s -> showSBool s True) (S.toList stanzas)---- | Options for goal qualification (used in 'qualifyDeps')------ See also 'defaultQualifyOptions'-data QualifyOptions = QO {-    -- | Do we have a version of base relying on another version of base?-    qoBaseShim :: Bool--    -- Should dependencies of the setup script be treated as independent?-  , qoSetupIndependent :: Bool-  }-  deriving Show---- | Apply built-in rules for package qualifiers------ Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions',--- it is important that these 'QualifyOptions' are _static_. Qualification--- does NOT depend on flag assignment; in other words, it behaves the same no--- matter which choices the solver makes (modulo the global 'QualifyOptions');--- we rely on this in 'linkDeps' (see comment there).------ NOTE: It's the _dependencies_ of a package that may or may not be independent--- from the package itself. Package flag choices must of course be consistent.-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN-qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go-  where-    go :: FlaggedDeps PN -> FlaggedDeps QPN-    go = map go1--    go1 :: FlaggedDep PN -> FlaggedDep QPN-    go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)-    go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)-    go1 (Simple dep comp)    = Simple (goLDep dep comp) comp--    -- Suppose package B has a setup dependency on package A.-    -- This will be recorded as something like-    ---    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion))-    ---    -- Observe that when we qualify this dependency, we need to turn that-    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier-    -- to the DependencyReason.-    goLDep :: LDep PN -> Component -> LDep QPN-    goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)--    goD :: Dep PN -> Component -> Dep QPN-    goD (Ext  ext)    _    = Ext  ext-    goD (Lang lang)   _    = Lang lang-    goD (Pkg pkn vr)  _    = Pkg pkn vr-    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =-        Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci-    goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp-      | qBase qpn   = Dep (Q (PackagePath ns (QualBase  pn)) <$> dep) ci-      | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci-      | otherwise   = Dep (Q (PackagePath ns inheritedQ    ) <$> dep) ci--    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then-    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup-    -- dependency on R. We do not do this for the base qualifier however.-    ---    -- The inherited qualifier is only used for regular dependencies; for setup-    -- and base deppendencies we override the existing qualifier. See #3160 for-    -- a detailed discussion.-    inheritedQ :: Qualifier-    inheritedQ = case q of-                   QualSetup _  -> q-                   QualExe _ _  -> q-                   QualToplevel -> q-                   QualBase _   -> QualToplevel--    -- Should we qualify this goal with the 'Base' package path?-    qBase :: PN -> Bool-    qBase dep = qoBaseShim && unPackageName dep == "base"--    -- Should we qualify this goal with the 'Setup' package path?-    qSetup :: Component -> Bool-    qSetup comp = qoSetupIndependent && comp == ComponentSetup---- | Remove qualifiers from set of dependencies------ This is used during link validation: when we link package @Q.A@ to @Q'.A@,--- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute--- what to link these dependencies to, we need to requalify @Q.B@ to become--- @Q'.B@; we do this by first removing all qualifiers and then calling--- 'qualifyDeps' again.-unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN-unqualifyDeps = go-  where-    go :: FlaggedDeps QPN -> FlaggedDeps PN-    go = map go1--    go1 :: FlaggedDep QPN -> FlaggedDep PN-    go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)-    go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)-    go1 (Simple dep comp)    = Simple (goLDep dep) comp--    goLDep :: LDep QPN -> LDep PN-    goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep)--    unq :: QPN -> PN-    unq (Q _ pn) = pn--{--------------------------------------------------------------------------------  Reverse dependency map--------------------------------------------------------------------------------}---- | A map containing reverse dependencies between qualified--- package names.-type RevDepMap = Map QPN [(Component, QPN)]--{--------------------------------------------------------------------------------  Goals--------------------------------------------------------------------------------}---- | A goal is just a solver variable paired with a reason.--- The reason is only used for tracing.-data Goal qpn = Goal (Var qpn) (GoalReason qpn)-  deriving (Eq, Show, Functor)---- | Reason why a goal is being added to a goal set.-data GoalReason qpn =-    UserGoal                              -- introduced by a build target-  | DependencyGoal (DependencyReason qpn) -- introduced by a package-  deriving (Eq, Show, Functor)--type QGoalReason = GoalReason QPN--goalToVar :: Goal a -> Var a-goalToVar (Goal v _) = v---- | Compute a singleton conflict set from a 'Var'-varToConflictSet :: Var QPN -> ConflictSet-varToConflictSet = CS.singleton---- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal--- leads to a conflict.-goalReasonToConflictSet :: GoalReason QPN -> ConflictSet-goalReasonToConflictSet UserGoal            = CS.empty-goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr---- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the--- conflict occurred, namely the conflict set variables caused a conflict by--- introducing the given package goal. See the documentation for 'GoalConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'GoalReason' does not involve any flags or stanzas.--- Otherwise, it falls back to calling 'goalReasonToConflictSet'.-goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet-goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas))-  | M.null flags && S.null stanzas =-      CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal-goalReasonToConflictSetWithConflict _    gr = goalReasonToConflictSet gr---- | This function returns the solver variables responsible for the dependency.--- It drops the values chosen for flag and stanza variables, which are only--- needed for log messages.-dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet-dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) =-    CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)-  where-    -- Filter out any flags that introduced the dependency with both values.-    -- They don't need to be included in the conflict set, because changing the-    -- flag value can't remove the dependency.-    flagVars :: [Var QPN]-    flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth]--    stanzaToVar :: Stanza -> Var QPN-    stanzaToVar = S . SN qpn---- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the--- conflict occurred because the conflict set variables introduced a problematic--- version constraint. See the documentation for 'VersionConstraintConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'DependencyReason' does not involve any flags or--- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.-dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN-                                                           -> Ver-                                                           -> DependencyReason QPN-                                                           -> ConflictSet-dependencyReasonToConflictSetWithVersionConstraintConflict-    dependency excludedVersion dr@(DependencyReason qpn flags stanzas)-  | M.null flags && S.null stanzas =-    CS.singletonWithConflict (P qpn) $-    CS.VersionConstraintConflict dependency excludedVersion-  | otherwise = dependencyReasonToConflictSet dr---- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the--- conflict occurred because the conflict set variables introduced a version of--- a package that was excluded by a version constraint. See the documentation--- for 'VersionConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'DependencyReason' does not involve any flags or--- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.-dependencyReasonToConflictSetWithVersionConflict :: QPN-                                                 -> CS.OrderedVersionRange-                                                 -> DependencyReason QPN-                                                 -> ConflictSet-dependencyReasonToConflictSetWithVersionConflict-    pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas)-  | M.null flags && S.null stanzas =-    CS.singletonWithConflict (P qpn) $-    CS.VersionConflict pkgWithVersionConstraint constraint-  | otherwise = dependencyReasonToConflictSet dr
− cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs 
@@ -1,367 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.Explore (backjumpAndExplore) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Distribution.Solver.Types.Progress as P--import qualified Data.List as L (foldl')-import qualified Data.Map.Strict as M-import qualified Data.Set as S--import Distribution.Simple.Setup (asBool)--import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Log-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Settings-         (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..))-import Distribution.Types.VersionRange (anyVersion)---- | This function takes the variable we're currently considering, a--- last conflict set and a list of children's logs. Each log yields--- either a solution or a conflict set. The result is a combined log for--- the parent node that has explored a prefix of the children.------ We can stop traversing the children's logs if we find an individual--- conflict set that does not contain the current variable. In this--- case, we can just lift the conflict set to the current level,--- because the current level cannot possibly have contributed to this--- conflict, so no other choice at the current level would avoid the--- conflict.------ If any of the children might contain a successful solution, we can--- return it immediately. If all children contain conflict sets, we can--- take the union as the combined conflict set.------ The last conflict set corresponds to the justification that we--- have to choose this goal at all. There is a reason why we have--- introduced the goal in the first place, and this reason is in conflict--- with the (virtual) option not to choose anything for the current--- variable. See also the comments for 'avoidSet'.------ We can also skip a child if it does not resolve any of the conflicts paired--- with the current variable in the previous child's conflict set. 'backjump'--- takes a function to determine whether a child can be skipped. If the child--- can be skipped, the function returns a new conflict set to be merged with the--- previous conflict set.----backjump :: forall w k a . Maybe Int-         -> EnableBackjumping-         -> FineGrainedConflicts--         -> (k -> S.Set CS.Conflict -> Maybe ConflictSet)-            -- ^ Function that determines whether the given choice could resolve-            --   the given conflict. It indicates false by returning 'Just',-            --   with the new conflicts to be added to the conflict set.--         -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a)-            -- ^ Function that logs the given choice that was skipped.--         -> Var QPN -- ^ The current variable.--         -> ConflictSet -- ^ Conflict set representing the reason that the goal-                        --   was introduced.--         -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a)-            -- ^ List of children's logs.--         -> ExploreState -> ConflictSetLog a-backjump mbj enableBj fineGrainedConflicts couldResolveConflicts-         logSkippedChoice var lastCS xs =-    foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing-  where-    combine :: (k, ExploreState -> ConflictSetLog a)-            -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a)-            ->  ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a-    combine (k, x) f csAcc mPreviousCS es =-        case (asBool fineGrainedConflicts, mPreviousCS) of-          (True, Just previousCS) ->-              case CS.lookup var previousCS of-                Just conflicts ->-                  case couldResolveConflicts k conflicts of-                    Nothing           -> retryNoSolution (x es) next-                    Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts)-                _              -> skipChoice previousCS-          _                       -> retryNoSolution (x es) next-      where-        next :: ConflictSet -> ExploreState -> ConflictSetLog a-        next !cs es' = if asBool enableBj && not (var `CS.member` cs)-                       then skipLoggingBackjump cs es'-                       else f (csAcc `CS.union` cs) (Just cs) es'--        -- This function is for skipping the choice when it cannot resolve any-        -- of the previous conflicts.-        skipChoice :: ConflictSet -> ConflictSetLog a-        skipChoice newCS =-            retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' ->-                f (csAcc `CS.union` cs') (Just cs') $--                -- Update the conflict map with the conflict set, to make up for-                -- skipping the whole subtree.-                es' { esConflictMap = updateCM cs' (esConflictMap es') }--    -- This function represents the option to not choose a value for this goal.-    avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a-    avoidGoal cs _mPreviousCS !es =-        logBackjump mbj (cs `CS.union` lastCS) $--        -- Use 'lastCS' below instead of 'cs' since we do not want to-        -- double-count the additionally accumulated conflicts.-        es { esConflictMap = updateCM lastCS (esConflictMap es) }--    -- The solver does not count or log backjumps at levels where the conflict-    -- set does not contain the current variable. Otherwise, there would be many-    -- consecutive log messages about backjumping with the same conflict set.-    skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a-    skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es)---- | Creates a failing ConflictSetLog representing a backjump. It inserts a--- "backjumping" message, checks whether the backjump limit has been reached,--- and increments the backjump count.-logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a-logBackjump mbj cs es =-    failWith (Failure cs Backjump) $-        if reachedBjLimit (esBackjumps es)-        then BackjumpLimit-        else NoSolution cs es { esBackjumps = esBackjumps es + 1 }-  where-    reachedBjLimit = case mbj of-                       Nothing    -> const False-                       Just limit -> (>= limit)---- | Like 'retry', except that it only applies the input function when the--- backjump limit has not been reached.-retryNoSolution :: ConflictSetLog a-                -> (ConflictSet -> ExploreState -> ConflictSetLog a)-                -> ConflictSetLog a-retryNoSolution lg f = retry lg $ \case-    BackjumpLimit    -> fromProgress (P.Fail BackjumpLimit)-    NoSolution cs es -> f cs es---- | The state that is read and written while exploring the search tree.-data ExploreState = ES {-    esConflictMap :: !ConflictMap-  , esBackjumps   :: !Int-  }--data IntermediateFailure =-    NoSolution ConflictSet ExploreState-  | BackjumpLimit--type ConflictSetLog = RetryLog Message IntermediateFailure--getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)-getBestGoal cm =-  P.maximumBy-    ( flip (M.findWithDefault 0) cm-    . (\ (Goal v _) -> v)-    )--getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a)-getFirstGoal ts =-  P.casePSQ ts-    (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error-    (\ k v _xs -> (k, v))  -- commit to the first goal choice--updateCM :: ConflictSet -> ConflictMap -> ConflictMap-updateCM cs cm =-  L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs)---- | Record complete assignments on 'Done' nodes.-assign :: Tree d c -> Tree Assignment c-assign tree = cata go tree $ A M.empty M.empty M.empty-  where-    go :: TreeF d c (Assignment -> Tree Assignment c)-                 -> (Assignment -> Tree Assignment c)-    go (FailF c fr)            _                  = Fail c fr-    go (DoneF rdm _)           a                  = Done rdm a-    go (PChoiceF qpn rdm y       ts) (A pa fa sa) = PChoice qpn rdm y       $ W.mapWithKey f ts-        where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)-    go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts-        where f k             r = r (A pa (M.insert qfn k fa) sa)-    go (SChoiceF qsn rdm y t     ts) (A pa fa sa) = SChoice qsn rdm y t     $ W.mapWithKey f ts-        where f k             r = r (A pa fa (M.insert qsn k sa))-    go (GoalChoiceF  rdm         ts) a            = GoalChoice  rdm         $ fmap ($ a) ts---- | A tree traversal that simultaneously propagates conflict sets up--- the tree from the leaves and creates a log.-exploreLog :: Maybe Int-           -> EnableBackjumping-           -> FineGrainedConflicts-           -> CountConflicts-           -> Index-           -> Tree Assignment QGoalReason-           -> ConflictSetLog (Assignment, RevDepMap)-exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t =-    para go t initES-  where-    getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)-    getBestGoal'-      | asBool countConflicts = \ ts cm -> getBestGoal cm ts-      | otherwise             = \ ts _  -> getFirstGoal ts--    go :: TreeF Assignment QGoalReason-                (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason)-                                    -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap))-    go (FailF c fr)                            = \ !es ->-        let es' = es { esConflictMap = updateCM c (esConflictMap es) }-        in failWith (Failure c fr) (NoSolution c es')-    go (DoneF rdm a)                           = \ _   -> succeedWith Success (a, rdm)-    go (PChoiceF qpn _ gr       ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (couldResolveConflicts qpn)-               (logSkippedPackage qpn)-               (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryP qpn k) (r es))-                 (fmap fst ts)-    go (FChoiceF qfn _ gr _ _ _ ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (\_ _ -> Nothing)-               (const logSkippedChoiceSimple)-               (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryF qfn k) (r es))-                 (fmap fst ts)-    go (SChoiceF qsn _ gr _     ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (\_ _ -> Nothing)-               (const logSkippedChoiceSimple)-               (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryS qsn k) (r es))-                 (fmap fst ts)-    go (GoalChoiceF _           ts)            = \ es ->-      let (k, (v, tree)) = getBestGoal' ts (esConflictMap es)-      in continueWith (Next k) $-         -- Goal choice nodes are normally not counted as backjumps, since the-         -- solver always explores exactly one choice, which means that the-         -- backjump from the goal choice would be redundant with the backjump-         -- from the PChoice, FChoice, or SChoice below. The one case where the-         -- backjump is not redundant is when the chosen goal is a failure node,-         -- so we log a backjump in that case.-         case tree of-           Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj-           _        -> v es--    initES = ES {-        esConflictMap = M.empty-      , esBackjumps = 0-      }--    -- Is it possible for this package instance (QPN and POption) to resolve any-    -- of the conflicts that were caused by the previous instance? The default-    -- is true, because it is always safe to explore a package instance.-    -- Skipping it is an optimization. If false, it returns a new conflict set-    -- to be merged with the previous one.-    couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet-    couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =-      let (PInfo deps _ _ _) = idx M.! pn M.! i-          qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps--          couldBeResolved :: CS.Conflict -> Maybe ConflictSet-          couldBeResolved CS.OtherConflict = Nothing-          couldBeResolved (CS.GoalConflict conflictingDep) =-              -- Check whether this package instance also has 'conflictingDep'-              -- as a dependency (ignoring flag and stanza choices).-              if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]-              then Nothing-              else Just CS.empty-          couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) =-              -- Check whether this package instance also excludes version-              -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices).-              let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ]-                  vrIntersection = L.foldl' (.&&.) anyVersion vrs-              in if checkVR vrIntersection excludedVersion-                 then Nothing-                 else -- If we skip this package instance, we need to update the-                      -- conflict set to say that 'dep' was also excluded by-                      -- this package instance's constraint.-                      Just $ CS.singletonWithConflict (P dep) $-                      CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection)-          couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) =-              -- Check whether this package instance's version is also excluded-              -- by 'excludingVR'.-              if checkVR excludingVR v-              then Nothing-              else -- If we skip this version, we need to update the conflict-                   -- set to say that the reverse dependency also excluded this-                   -- version.-                   Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v)-      in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts)--    logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a-    logSkippedPackage qpn pOption cs es =-        tryWith (TryP qpn pOption) $-        failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $-        NoSolution cs es--    -- This function is used for flag and stanza choices, but it should not be-    -- called, because there is currently no way to skip a value for a flag or-    -- stanza.-    logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a-    logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es---- | Build a conflict set corresponding to the (virtual) option not to--- choose a solution for a goal at all.------ In the solver, the set of goals is not statically determined, but depends--- on the choices we make. Therefore, when dealing with conflict sets, we--- always have to consider that we could perhaps make choices that would--- avoid the existence of the goal completely.------ Whenever we actually introduce a choice in the tree, we have already established--- that the goal cannot be avoided. This is tracked in the "goal reason".--- The choice to avoid the goal therefore is a conflict between the goal itself--- and its goal reason. We build this set here, and pass it to the 'backjump'--- function as the last conflict set.------ This has two effects:------ - In a situation where there are no choices available at all (this happens--- if an unknown package is requested), the last conflict set becomes the--- actual conflict set.------ - In a situation where all of the children's conflict sets contain the--- current variable, the goal reason of the current node will be added to the--- conflict set.----avoidSet :: Var QPN -> QGoalReason -> ConflictSet-avoidSet var@(P qpn) gr =-  CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr)-avoidSet var         gr =-  CS.union (CS.singleton var) (goalReasonToConflictSet gr)---- | Interface.------ Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing',--- then infinitely many backjumps are allowed. If the limit is 'Just 0',--- backtracking is completely disabled.-backjumpAndExplore :: Maybe Int-                   -> EnableBackjumping-                   -> FineGrainedConflicts-                   -> CountConflicts-                   -> Index-                   -> Tree d QGoalReason-                   -> RetryLog Message SolverFailure (Assignment, RevDepMap)-backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx =-    mapFailure convertFailure-  . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx-  . assign-  where-    convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es)-    convertFailure BackjumpLimit      = BackjumpLimitReached
− cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Flag-    ( FInfo(..)-    , Flag-    , FlagInfo-    , FN(..)-    , QFN-    , QSN-    , Stanza-    , SN(..)-    , WeakOrTrivial(..)-    , FlagValue(..)-    , mkFlag-    , showQFN-    , showQFNBool-    , showFlagValue-    , showQSN-    , showQSNBool-    , showSBool-    ) where--import Data.Map as M-import Prelude hiding (pi)--import qualified Distribution.PackageDescription as P -- from Cabal--import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath---- | Flag name. Consists of a package instance and the flag identifier itself.-data FN qpn = FN qpn Flag-  deriving (Eq, Ord, Show, Functor)---- | Flag identifier. Just a string.-type Flag = P.FlagName---- | Stanza identifier.-type Stanza = OptionalStanza--unFlag :: Flag -> String-unFlag = P.unFlagName--mkFlag :: String -> Flag-mkFlag = P.mkFlagName---- | Flag info. Default value, whether the flag is manual, and--- whether the flag is weak. Manual flags can only be set explicitly.--- Weak flags are typically deferred by the solver.-data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial }-  deriving (Eq, Show)---- | Flag defaults.-type FlagInfo = Map Flag FInfo---- | Qualified flag name.-type QFN = FN QPN---- | Stanza name. Paired with a package name, much like a flag.-data SN qpn = SN qpn Stanza-  deriving (Eq, Ord, Show, Functor)---- | Qualified stanza name.-type QSN = SN QPN---- | A property of flag and stanza choices that determines whether the--- choice should be deferred in the solving process.------ A choice is called weak if we do want to defer it. This is the--- case for flags that should be implied by what's currently installed on--- the system, as opposed to flags that are used to explicitly enable or--- disable some functionality.------ A choice is called trivial if it clearly does not matter. The--- special case of triviality we actually consider is if there are no new--- dependencies introduced by the choice.-newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }-  deriving (Eq, Ord, Show)---- | Value shown for a flag in a solver log message. The message can refer to--- only the true choice, only the false choice, or both choices.-data FlagValue = FlagTrue | FlagFalse | FlagBoth-  deriving (Eq, Show)--showQFNBool :: QFN -> Bool -> String-showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b--showQSNBool :: QSN -> Bool -> String-showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b--showFBool :: FN qpn -> Bool -> String-showFBool (FN _ f) v = P.showFlagValue (f, v)---- | String representation of a flag-value pair.-showFlagValue :: P.FlagName -> FlagValue -> String-showFlagValue f FlagTrue  = '+' : unFlag f-showFlagValue f FlagFalse = '-' : unFlag f-showFlagValue f FlagBoth  = "+/-" ++ unFlag f--showSBool :: Stanza -> Bool -> String-showSBool s True  = "*" ++ showStanza s-showSBool s False = "!" ++ showStanza s--showQFN :: QFN -> String-showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f--showQSN :: QSN -> String-showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s
− cabal-install-solver/src/Distribution/Solver/Modular/Index.hs 
@@ -1,74 +0,0 @@-module Distribution.Solver.Modular.Index-    ( Index-    , PInfo(..)-    , ComponentInfo(..)-    , IsVisible(..)-    , IsBuildable(..)-    , defaultQualifyOptions-    , mkIndex-    ) where--import Prelude hiding (pi)--import Data.Map (Map)-import qualified Data.List as L-import qualified Data.Map as M--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree---- | An index contains information about package instances. This is a nested--- dictionary. Package names are mapped to instances, which in turn is mapped--- to info.-type Index = Map PN (Map I PInfo)---- | Info associated with a package instance.--- Currently, dependencies, component names, flags and failure reasons.--- The component map records whether any components are unbuildable in the--- current environment (compiler, os, arch, and global flag constraints).--- Packages that have a failure reason recorded for them are disabled--- globally, for reasons external to the solver. We currently use this--- for shadowing which essentially is a GHC limitation, and for--- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps PN)-                   (Map ExposedComponent ComponentInfo)-                   FlagInfo-                   (Maybe FailReason)---- | Info associated with each library and executable in a package instance.-data ComponentInfo = ComponentInfo {-    compIsVisible   :: IsVisible-  , compIsBuildable :: IsBuildable-  }-  deriving Show---- | Whether a component is visible in the current environment.-newtype IsVisible = IsVisible Bool-  deriving (Eq, Show)---- | Whether a component is made unbuildable by a "buildable: False" field.-newtype IsBuildable = IsBuildable Bool-  deriving (Eq, Show)--mkIndex :: [(PN, I, PInfo)] -> Index-mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))--groupMap :: Ord a => [(a, b)] -> Map a [b]-groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)--defaultQualifyOptions :: Index -> QualifyOptions-defaultQualifyOptions idx = QO {-      qoBaseShim         = or [ dep == base-                              | -- Find all versions of base ..-                                Just is <- [M.lookup base idx]-                                -- .. which are installed ..-                              , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is-                                -- .. and flatten all their dependencies ..-                              , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps-                              ]-    , qoSetupIndependent = True-    }-  where-    base = mkPackageName "base"
− cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs 
@@ -1,562 +0,0 @@-module Distribution.Solver.Modular.IndexConversion-    ( convPIs-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Data.List as L-import qualified Data.Map.Strict as M-import qualified Distribution.Compat.NonEmptySet as NonEmptySet-import qualified Data.Set as S--import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Compiler-import Distribution.Package                          -- from Cabal-import Distribution.Simple.BuildToolDepends          -- from Cabal-import Distribution.Types.ExeDependency              -- from Cabal-import Distribution.Types.PkgconfigDependency        -- from Cabal-import Distribution.Types.ComponentName              -- from Cabal-import Distribution.Types.CondTree                   -- from Cabal-import Distribution.Types.MungedPackageId            -- from Cabal-import Distribution.Types.MungedPackageName          -- from Cabal-import Distribution.PackageDescription               -- from Cabal-import Distribution.PackageDescription.Configuration-import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System--import           Distribution.Solver.Types.ComponentDeps-                   ( Component(..), componentNameToComponent )-import           Distribution.Solver.Types.Flag-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PackageConstraint-import qualified Distribution.Solver.Types.PackageIndex as CI-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.SourcePackage--import Distribution.Solver.Modular.Dependency as D-import Distribution.Solver.Modular.Flag as F-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version---- | Convert both the installed package index and the source package--- index into one uniform solver index.------ We use 'allPackagesBySourcePackageId' for the installed package index--- because that returns us several instances of the same package and version--- in order of preference. This allows us in principle to \"shadow\"--- packages if there are several installed packages of the same version.--- There are currently some shortcomings in both GHC and Cabal in--- resolving these situations. However, the right thing to do is to--- fix the problem there, so for now, shadowing is only activated if--- explicitly requested.-convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]-        -> ShadowPkgs -> StrongFlags -> SolveExecutables-        -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)-        -> Index-convPIs os arch comp constraints sip strfl solveExes iidx sidx =-  mkIndex $-  convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx---- | Convert a Cabal installed package index to the simpler,--- more uniform index format of the solver.-convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]-convIPI' (ShadowPkgs sip) idx =-    -- apply shadowing whenever there are multiple installed packages with-    -- the same version-    [ maybeShadow (convIP idx pkg)-    -- IMPORTANT to get internal libraries. See-    -- Note [Index conversion with internal libraries]-    | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx-    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]-  where--    -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps comps fds _)-      | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))-    shadow x                                     = x---- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.-convId :: IPI.InstalledPackageInfo -> (PN, I)-convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)-  where MungedPackageId mpn ver = mungedId ipi-        -- HACK. See Note [Index conversion with internal libraries]-        pn = encodeCompatPackageName mpn---- | Convert a single installed package into the solver-specific format.-convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)-convIP idx ipi =-  case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of-        Left u    -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))-        Right fds -> (pn, i, PInfo fds components M.empty Nothing)- where-  -- TODO: Handle sub-libraries and visibility.-  components =-      M.singleton (ExposedLib LMainLibName)-                  ComponentInfo {-                      compIsVisible = IsVisible True-                    , compIsBuildable = IsBuildable True-                    }--  (pn, i) = convId ipi--  -- 'sourceLibName' is unreliable, but for now we only really use this for-  -- primary libs anyways-  comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi--- TODO: Installed packages should also store their encapsulations!---- Note [Index conversion with internal libraries]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Something very interesting happens when we have internal libraries--- in our index.  In this case, we maybe have p-0.1, which itself--- depends on the internal library p-internal ALSO from p-0.1.--- Here's the danger:------      - If we treat both of these packages as having PN "p",---        then the solver will try to pick one or the other,---        but never both.------      - If we drop the internal packages, now p-0.1 has a---        dangling dependency on an "installed" package we know---        nothing about. Oops.------ An expedient hack is to put p-internal into cabal-install's--- index as a MUNGED package name, so that it doesn't conflict--- with anyone else (except other instances of itself).  But--- yet, we ought NOT to say that PNs in the solver are munged--- package names, because they're not; for source packages,--- we really will never see munged package names.------ The tension here is that the installed package index is actually--- per library, but the solver is per package.  We need to smooth--- it over, and munging the package names is a pretty good way to--- do it.---- | Convert dependencies specified by an installed package id into--- flagged dependencies of the solver.------ May return Nothing if the package can't be found in the index. That--- indicates that the original package having this dependency is broken--- and should be ignored.-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)-convIPId dr comp idx ipid =-  case SI.lookupUnitId idx ipid of-    Nothing  -> Left ipid-    Just ipi -> let (pn, i) = convId ipi-                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.-                in  Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)-                -- NB: something we pick up from the-                -- InstalledPackageIndex is NEVER an executable---- | Convert a cabal-install source package index to the simpler,--- more uniform index format of the solver.-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]-         -> StrongFlags -> SolveExecutables-         -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]-convSPI' os arch cinfo constraints strfl solveExes =-    L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages---- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]-       -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)-convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =-  let i = I pv InRepo-      pkgConstraints = fromMaybe [] $ M.lookup pn constraints-  in  (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)---- We do not use 'flattenPackageDescription' or 'finalizePD'--- from 'Distribution.PackageDescription.Configuration' here, because we--- want to keep the condition tree, but simplify much of the test.---- | Convert a generic package description to a solver-specific 'PInfo'.-convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]-        -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription-        -> PInfo-convGPD os arch cinfo constraints strfl solveExes pn-        (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =-  let-    fds  = flagInfo strfl flags---    conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps PN-    conv comp getInfo dr =-        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .-        addBuildableCondition getInfo--    initDR = DependencyReason pn M.empty S.empty--    flagged_deps-        = concatMap (\ds ->       conv ComponentLib         libBuildInfo        initDR ds) (maybeToList mlib)-       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo        initDR ds) sub_libs-       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)   foreignLibBuildInfo initDR ds) flibs-       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)    buildInfo           initDR ds) exes-       ++ prefix (Stanza (SN pn TestStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentTest nm)   testBuildInfo (addStanza TestStanzas initDR) ds)-                    tests)-       ++ prefix (Stanza (SN pn BenchStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentBench nm)  benchmarkBuildInfo (addStanza BenchStanzas initDR) ds)-                    benchs)-       ++ maybe []  (convSetupBuildInfo pn) (setupBuildInfo pkg)--    addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn-    addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss)--    -- | A too-new specVersion is turned into a global 'FailReason'-    -- which prevents the solver from selecting this release (and if-    -- forced to, emit a meaningful solver error message).-    fr = case scannedVersion of-        Just ver -> Just (UnsupportedSpecVer ver)-        Nothing  -> Nothing--    components :: Map ExposedComponent ComponentInfo-    components = M.fromList $ libComps ++ subLibComps ++ exeComps-      where-        libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib)-                   | lib <- maybeToList mlib ]-        subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib)-                      | (name, lib) <- sub_libs ]-        exeComps = [ ( ExposedExe name-                     , ComponentInfo {-                           compIsVisible = IsVisible True-                         , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False-                         }-                     )-                   | (name, exe) <- exes ]--        libToComponentInfo lib =-            ComponentInfo {-                compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True-              , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False-              }--        testCondition = testConditionForComponent os arch cinfo constraints--        isPrivate LibraryVisibilityPrivate = True-        isPrivate LibraryVisibilityPublic  = False--  in PInfo flagged_deps components fds fr---- | Applies the given predicate (for example, testing buildability or--- visibility) to the given component and environment. Values are combined with--- AND. This function returns 'Nothing' when the result cannot be determined--- before dependency solving. Additionally, this function only considers flags--- that are set by unqualified flag constraints, and it doesn't check the--- intra-package dependencies of a component.-testConditionForComponent :: OS-                          -> Arch-                          -> CompilerInfo-                          -> [LabeledPackageConstraint]-                          -> (a -> Bool)-                          -> CondTree ConfVar [Dependency] a-                          -> Maybe Bool-testConditionForComponent os arch cinfo constraints p tree =-    case go $ extractCondition p tree of-      Lit True  -> Just True-      Lit False -> Just False-      _         -> Nothing-  where-    flagAssignment :: [(FlagName, Bool)]-    flagAssignment =-        mconcat [ unFlagAssignment fa-                | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)-                    <- L.map unlabelPackageConstraint constraints]--    -- Simplify the condition, using the current environment. Most of this-    -- function was copied from convBranch and-    -- Distribution.Types.Condition.simplifyCondition.-    go :: Condition ConfVar -> Condition ConfVar-    go (Var (OS os')) = Lit (os == os')-    go (Var (Arch arch')) = Lit (arch == arch')-    go (Var (Impl cf cvr))-        | matchImpl (compilerInfoId cinfo) ||-              -- fixme: Nothing should be treated as unknown, rather than empty-              --        list. This code should eventually be changed to either-              --        support partial resolution of compiler flags or to-              --        complain about incompletely configured compilers.-          any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True-        | otherwise = Lit False-      where-        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv-    go (Var (PackageFlag f))-        | Just b <- L.lookup f flagAssignment = Lit b-    go (Var v) = Var v-    go (Lit b) = Lit b-    go (CNot c) =-        case go c of-          Lit True -> Lit False-          Lit False -> Lit True-          c' -> CNot c'-    go (COr c d) =-        case (go c, go d) of-          (Lit False, d') -> d'-          (Lit True, _)   -> Lit True-          (c', Lit False) -> c'-          (_, Lit True)   -> Lit True-          (c', d')        -> COr c' d'-    go (CAnd c d) =-        case (go c, go d) of-          (Lit False, _) -> Lit False-          (Lit True, d') -> d'-          (_, Lit False) -> Lit False-          (c', Lit True) -> c'-          (c', d')       -> CAnd c' d'---- | Create a flagged dependency tree from a list @fds@ of flagged--- dependencies, using @f@ to form the tree node (@f@ will be--- something like @Stanza sn@).-prefix :: (FlaggedDeps qpn -> FlaggedDep qpn)-       -> [FlaggedDeps qpn] -> FlaggedDeps qpn-prefix _ []  = []-prefix f fds = [f (concat fds)]---- | Convert flag information. Automatic flags are now considered weak--- unless strong flags have been selected explicitly.-flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo-flagInfo (StrongFlags strfl) =-    M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))-  where-    weak m = WeakOrTrivial $ not (strfl || m)-    flagType m = if m then Manual else Automatic---- | Convert condition trees to flagged dependencies.  Mutually--- recursive with 'convBranch'.  See 'convBranch' for an explanation--- of all arguments preceding the input 'CondTree'.-convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->-                Component ->-                (a -> BuildInfo) ->-                SolveExecutables ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =-             -- Merge all library and build-tool dependencies at every level in-             -- the tree of flagged dependencies. Otherwise 'extractCommon'-             -- could create duplicate dependencies, and the number of-             -- duplicates could grow exponentially from the leaves to the root-             -- of the tree.-             mergeSimpleDeps $-                 [ D.Simple singleDep comp-                 | dep <- ds-                 , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies--              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches-              -- build-tools dependencies-              -- NB: Only include these dependencies if SolveExecutables-              -- is True.  It might be false in the legacy solver-              -- codepath, in which case there won't be any record of-              -- an executable we need.-              ++ [ D.Simple (convExeDep dr exeDep) comp-                 | solveExes'-                 , exeDep <- getAllToolDependencies pkg bi-                 , not $ isInternal pkg exeDep-                 ]-  where-    bi = getInfo info--data SimpleFlaggedDepKey qpn =-    SimpleFlaggedDepKey (PkgComponent qpn) Component-  deriving (Eq, Ord)--data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR---- | Merge 'Simple' dependencies that apply to the same library or build-tool.--- This function should be able to merge any two dependencies that can be merged--- by extractCommon, in order to prevent the exponential growth of dependencies.------ Note that this function can merge dependencies that have different--- DependencyReasons, which can make the DependencyReasons less precise. This--- loss of precision only affects performance and log messages, not correctness.--- However, when 'mergeSimpleDeps' is only called on dependencies at a single--- location in the dependency tree, the only difference between--- DependencyReasons should be flags that have value FlagBoth. Adding extra--- flags with value FlagBoth should not affect performance, since they are not--- added to the conflict set. The only downside is the possibility of the log--- incorrectly saying that the flag contributed to excluding a specific version--- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB--- introduces pkg <5, the merged dependency would mean that--- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply--- that +/-flagA excludes pkg-6.-mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn-mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged-  where-    (merged, unmerged) = L.foldl' f (M.empty, []) deps-      where-        f :: Ord qpn-          => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)-          -> FlaggedDep qpn-          -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)-        f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) =-            ( M.insertWith mergeValues-                           (SimpleFlaggedDepKey dep comp)-                           (SimpleFlaggedDepValue dr vr)-                           merged'-            , unmerged')-        f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged')--        mergeValues :: SimpleFlaggedDepValue qpn-                    -> SimpleFlaggedDepValue qpn-                    -> SimpleFlaggedDepValue qpn-        mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) =-            SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2)--    toFlaggedDep :: SimpleFlaggedDepKey qpn-                 -> SimpleFlaggedDepValue qpn-                 -> FlaggedDep qpn-    toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =-        D.Simple (LDep dr (Dep dep (Constrained vr))) comp---- | Branch interpreter.  Mutually recursive with 'convCondTree'.------ Here, we try to simplify one of Cabal's condition tree branches into the--- solver's flagged dependency format, which is weaker. Condition trees can--- contain complex logical expression composed from flag choices and special--- flags (such as architecture, or compiler flavour). We try to evaluate the--- special flags and subsequently simplify to a tree that only depends on--- simple flag choices.------ This function takes a number of arguments:------      1. A map of flag values that have already been chosen. It allows---         convBranch to avoid creating nested FlaggedDeps that are---         controlled by the same flag and avoid creating DependencyReasons with---         conflicting values for the same flag.------      2. The DependencyReason calculated at this point in the tree of---         conditionals. The flag values in the DependencyReason are similar to---         the values in the map above, except for the use of FlagBoth.------      3. Some pre dependency-solving known information ('OS', 'Arch',---         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,------      4. The package name @'PN'@ which this condition tree---         came from, so that we can correctly associate @flag()@---         variables with the correct package name qualifier,------      5. The flag defaults 'FlagInfo' so that we can populate---         'Flagged' dependencies with 'FInfo',------      6. The name of the component 'Component' so we can record where---         the fine-grained information about where the component came---         from (see 'convCondTree'), and------      7. A selector to extract the 'BuildInfo' from the leaves of---         the 'CondTree' (which actually contains the needed---         dependency information.)------      8. The set of package names which should be considered internal---         dependencies, and thus not handled as dependencies.-convBranch :: Map FlagName Bool-           -> DependencyReason PN-           -> PackageDescription-           -> OS-           -> Arch-           -> CompilerInfo-           -> PN-           -> FlagInfo-           -> Component-           -> (a -> BuildInfo)-           -> SolveExecutables-           -> CondBranch ConfVar [Dependency] a-           -> FlaggedDeps PN-convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =-    go c'-       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes  t')-       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf')-       flags dr-  where-    go :: Condition ConfVar-       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)-       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)-       ->  Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN-    go (Lit True)  t _ = t-    go (Lit False) _ f = f-    go (CNot c)    t f = go c f t-    go (CAnd c d)  t f = go c (go d t f) f-    go (COr  c d)  t f = go c t (go d t f)-    go (Var (PackageFlag fn)) t f = \flags' ->-        case M.lookup fn flags' of-          Just True  -> t flags'-          Just False -> f flags'-          Nothing    -> \dr' ->-            -- Add each flag to the DependencyReason for all dependencies below,-            -- including any extracted dependencies. Extracted dependencies are-            -- introduced by both flag values (FlagBoth). Note that we don't-            -- actually need to add the flag to the extracted dependencies for-            -- correct backjumping; the information only improves log messages-            -- by giving the user the full reason for each dependency.-            let addFlagValue v = addFlagToDependencyReason fn v dr'-                addFlag v = M.insert fn v flags'-            in extractCommon (t (addFlag True)  (addFlagValue FlagBoth))-                             (f (addFlag False) (addFlagValue FlagBoth))-                ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True)  (addFlagValue FlagTrue))-                                                     (f (addFlag False) (addFlagValue FlagFalse)) ]-    go (Var (OS os')) t f-      | os == os'      = t-      | otherwise      = f-    go (Var (Arch arch')) t f-      | arch == arch'  = t-      | otherwise      = f-    go (Var (Impl cf cvr)) t f-      | matchImpl (compilerInfoId cinfo) ||-            -- fixme: Nothing should be treated as unknown, rather than empty-            --        list. This code should eventually be changed to either-            --        support partial resolution of compiler flags or to-            --        complain about incompletely configured compilers.-        any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t-      | otherwise      = f-      where-        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv--    addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn-    addFlagToDependencyReason fn v (DependencyReason pn' fs ss) =-        DependencyReason pn' (M.insert fn v fs) ss--    -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but with the union of version ranges. This-    -- heuristic together with deferring flag choices will then usually first-    -- resolve this package, and try an already installed version before imposing-    -- a default flag choice that might not be what we want.-    ---    -- Note that we make assumptions here on the form of the dependencies that-    -- can occur at this point. In particular, no occurrences of Fixed, as all-    -- dependencies below this point have been generated using 'convLibDep'.-    ---    -- WARNING: This is quadratic!-    extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn-    extractCommon ps ps' =-        -- Union the DependencyReasons, because the extracted dependency can be-        -- avoided by removing the dependency from either side of the-        -- conditional.-        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp-        | D.Simple (LDep vs1                (Dep dep1 (Constrained vr1))) _ <- ps-        , D.Simple (LDep vs2                (Dep dep2 (Constrained vr2))) _ <- ps'-        , dep1 == dep2-        ]---- | Merge DependencyReasons by unioning their variables.-unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn-unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =-    DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2)---- | Convert a Cabal dependency on a set of library components (from a single--- package) to solver-specific dependencies.-convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN]-convLibDeps dr (Dependency pn vr libs) =-    [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr)-    | lib <- NonEmptySet.toList libs ]---- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.-convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN-convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr)---- | Convert setup dependencies-convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN-convSetupBuildInfo pn nfo =-    [ D.Simple singleDep ComponentSetup-    | dep <- setupDepends nfo-    , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ]
− cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs 
@@ -1,117 +0,0 @@--- | Wrapper around Data.Graph with support for edge labels-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.LabeledGraph (-    -- * Graphs-    Graph-  , Vertex-    -- ** Building graphs-  , graphFromEdges-  , graphFromEdges'-  , buildG-  , transposeG-    -- ** Graph properties-  , vertices-  , edges-    -- ** Operations on the underlying unlabeled graph-  , forgetLabels-  , topSort-  ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Data.Array-import Data.Graph (Vertex, Bounds)-import qualified Data.Graph as G--{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}--type Graph e = Array Vertex [(e, Vertex)]-type Edge  e = (Vertex, e, Vertex)--{--------------------------------------------------------------------------------  Building graphs--------------------------------------------------------------------------------}---- | Construct an edge-labeled graph------ This is a simple adaptation of the definition in Data.Graph-graphFromEdges :: forall key node edge. Ord key-               => [ (node, key, [(edge, key)]) ]-               -> ( Graph edge-                  , Vertex -> (node, key, [(edge, key)])-                  , key -> Maybe Vertex-                  )-graphFromEdges edges0 =-    (graph, \v -> vertex_map ! v, key_vertex)-  where-    max_v        = length edges0 - 1-    bounds0      = (0, max_v) :: (Vertex, Vertex)-    sorted_edges = sortBy lt edges0-    edges1       = zip [0..] sorted_edges--    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))-                                 | (v, (_, _, ks)) <- edges1]-    key_map      = array bounds0 [(v, k                    )-                                 | (v, (_, k, _ )) <- edges1]-    vertex_map   = array bounds0 edges1--    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2--    mk_edge :: (edge, key) -> Maybe (edge, Vertex)-    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)--    --  returns Nothing for non-interesting vertices-    key_vertex :: key -> Maybe Vertex-    key_vertex k = findVertex 0 max_v-      where-        findVertex a b-          | a > b     = Nothing-          | otherwise = case compare k (key_map ! mid) of-              LT -> findVertex a (mid-1)-              EQ -> Just mid-              GT -> findVertex (mid+1) b-          where-            mid = a + (b - a) `div` 2--graphFromEdges' :: Ord key-                => [ (node, key, [(edge, key)]) ]-                -> ( Graph edge-                   , Vertex -> (node, key, [(edge, key)])-                   )-graphFromEdges' x = (a,b)-  where-    (a,b,_) = graphFromEdges x--transposeG :: Graph e -> Graph e-transposeG g = buildG (bounds g) (reverseE g)--buildG :: Bounds -> [Edge e] -> Graph e-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)-  where-    reassoc (v, e, w) = (v, (e, w))--reverseE :: Graph e -> [Edge e]-reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]--{--------------------------------------------------------------------------------  Graph properties--------------------------------------------------------------------------------}--vertices :: Graph e -> [Vertex]-vertices = indices--edges :: Graph e -> [Edge e]-edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]--{--------------------------------------------------------------------------------  Operations on the underlying unlabelled graph--------------------------------------------------------------------------------}--forgetLabels :: Graph e -> G.Graph-forgetLabels = fmap (map snd)--topSort :: Graph e -> [Vertex]-topSort = G.topSort . forgetLabels
− cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs 
@@ -1,519 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- TODO: remove this-{-# OPTIONS -fno-warn-incomplete-uni-patterns #-}-module Distribution.Solver.Modular.Linking (-    validateLinking-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (get,put)--import Control.Exception (assert)-import Control.Monad.Reader-import Control.Monad.State-import Data.Map ((!))-import qualified Data.Map         as M-import qualified Data.Set         as S-import qualified Data.Traversable as T--import Distribution.Client.Utils.Assertion-import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath-import Distribution.Types.Flag (unFlagName)--{--------------------------------------------------------------------------------  Validation--  Validation of links is a separate pass that's performed after normal-  validation. Validation of links checks that if the tree indicates that a-  package is linked, then everything underneath that choice really matches the-  package we have linked to.--  This is interesting because it isn't unidirectional. Consider that we've-  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.-  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that-  a.bar and b.bar are also linked. However, it's not required that we actually-  choose a.bar before b.bar. Goal choice order is relatively free. It's possible-  that we choose a.bar first, but also possible that we choose b.bar first. In-  both cases, we have to recognize that we have freedom of choice for the first-  of the two, but no freedom of choice for the second.--  This is what LinkGroups are all about. Using LinkGroup, we can record (in the-  situation above) that a.bar and b.bar need to be linked even if we haven't-  chosen either of them yet.--------------------------------------------------------------------------------}--data ValidateState = VS {-      vsIndex    :: Index-    , vsLinks    :: Map QPN LinkGroup-    , vsFlags    :: FAssignment-    , vsStanzas  :: SAssignment-    , vsQualifyOptions :: QualifyOptions--    -- Saved qualified dependencies. Every time 'validateLinking' makes a-    -- package choice, it qualifies the package's dependencies and saves them in-    -- this map. Then the qualified dependencies are available for subsequent-    -- flag and stanza choices for the same package.-    , vsSaved    :: Map QPN (FlaggedDeps QPN)-    }--type Validate = Reader ValidateState---- | Validate linked packages------ Verify that linked packages have------ * Linked dependencies,--- * Equal flag assignments--- * Equal stanza assignments-validateLinking :: Index -> Tree d c -> Tree d c-validateLinking index = (`runReader` initVS) . cata go-  where-    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)--    go (PChoiceF qpn rdm gr       cs) =-      PChoice qpn rdm gr       <$> T.sequence (W.mapWithKey (goP qpn) cs)-    go (FChoiceF qfn rdm gr t m d cs) =-      FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)-    go (SChoiceF qsn rdm gr t     cs) =-      SChoice qsn rdm gr t     <$> T.sequence (W.mapWithKey (goS qsn) cs)--    -- For the other nodes we just recurse-    go (GoalChoiceF rdm           cs) = GoalChoice rdm <$> T.sequence cs-    go (DoneF revDepMap s)            = return $ Done revDepMap s-    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason--    -- Package choices-    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)-    goP qpn@(Q _pp pn) opt@(POption i _) r = do-      vs <- ask-      let PInfo deps _ _ _ = vsIndex vs ! pn ! i-          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps-          newSaved         = M.insert qpn qdeps (vsSaved vs)-      case execUpdateState (pickPOption qpn opt qdeps) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs' { vsSaved = newSaved }) r--    -- Flag choices-    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goF qfn b r = do-      vs <- ask-      case execUpdateState (pickFlag qfn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    -- Stanza choices (much the same as flag choices)-    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goS qsn b r = do-      vs <- ask-      case execUpdateState (pickStanza qsn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    initVS :: ValidateState-    initVS = VS {-        vsIndex   = index-      , vsLinks   = M.empty-      , vsFlags   = M.empty-      , vsStanzas = M.empty-      , vsQualifyOptions = defaultQualifyOptions index-      , vsSaved   = M.empty-      }--{--------------------------------------------------------------------------------  Updating the validation state--------------------------------------------------------------------------------}--type Conflict = (ConflictSet, String)--newtype UpdateState a = UpdateState {-    unUpdateState :: StateT ValidateState (Either Conflict) a-  }-  deriving (Functor, Applicative, Monad)--instance MonadState ValidateState UpdateState where-  get    = UpdateState $ get-  put st = UpdateState $ do-             expensiveAssert (lgInvariant $ vsLinks st) $ return ()-             put st--lift' :: Either Conflict a -> UpdateState a-lift' = UpdateState . lift--conflict :: Conflict -> UpdateState a-conflict = lift' . Left--execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState-execUpdateState = execStateT . unUpdateState--pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()-pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i-pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps--pickConcrete :: QPN -> I -> UpdateState ()-pickConcrete qpn@(Q pp _) i = do-    vs <- get-    case M.lookup qpn (vsLinks vs) of-      -- Package is not yet in a LinkGroup. Create a new singleton link group.-      Nothing -> do-        let lg = lgSingleton qpn (Just $ PI pp i)-        updateLinkGroup lg--      -- Package is already in a link group. Since we are picking a concrete-      -- instance here, it must by definition be the canonical package.-      Just lg ->-        makeCanonical lg qpn i--pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()-pickLink qpn@(Q _pp pn) i pp' deps = do-    vs <- get--    -- The package might already be in a link group-    -- (because one of its reverse dependencies is)-    let lgSource = case M.lookup qpn (vsLinks vs) of-                     Nothing -> lgSingleton qpn Nothing-                     Just lg -> lg--    -- Find the link group for the package we are linking to-    ---    -- Since the builder never links to a package without having first picked a-    -- concrete instance for that package, and since we create singleton link-    -- groups for concrete instances, this link group must exist (and must-    -- in fact already have a canonical member).-    let target   = Q pp' pn-        lgTarget = vsLinks vs ! target--    -- Verify here that the member we add is in fact for the same package and-    -- matches the version of the canonical instance. However, violations of-    -- these checks would indicate a bug in the linker, not a true conflict.-    let sanityCheck :: Maybe (PI PackagePath) -> Bool-        sanityCheck Nothing              = False-        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI-    assert (sanityCheck (lgCanon lgTarget)) $ return ()--    -- Merge the two link groups (updateLinkGroup will propagate the change)-    lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget-    updateLinkGroup lgTarget'--    -- Make sure all dependencies are linked as well-    linkDeps target deps--makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()-makeCanonical lg qpn@(Q pp _) i =-    case lgCanon lg of-      -- There is already a canonical member. Fail.-      Just _ ->-        conflict ( CS.insert (P qpn) (lgConflictSet lg)-                 ,    "cannot make " ++ showQPN qpn-                   ++ " canonical member of " ++ showLinkGroup lg-                 )-      Nothing -> do-        let lg' = lg { lgCanon = Just (PI pp i) }-        updateLinkGroup lg'---- | Link the dependencies of linked parents.------ When we decide to link one package against another we walk through the--- package's direct depedencies and make sure that they're all linked to each--- other by merging their link groups (or creating new singleton link groups if--- they don't have link groups yet). We do not need to do this recursively,--- because having the direct dependencies in a link group means that we must--- have already made or will make sooner or later a link choice for one of these--- as well, and cover their dependencies at that point.-linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()-linkDeps target = \deps -> do-    -- linkDeps is called in two places: when we first link one package to-    -- another, and when we discover more dependencies of an already linked-    -- package after doing some flag assignment. It is therefore important that-    -- flag assignments cannot influence _how_ dependencies are qualified;-    -- fortunately this is a documented property of 'qualifyDeps'.-    rdeps <- requalify deps-    go deps rdeps-  where-    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()-    go = zipWithM_ go1--    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()-    go1 dep rdep = case (dep, rdep) of-      (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do-        vs <- get-        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs-            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs-        lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg'-        updateLinkGroup lg''-      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do-        vs <- get-        case M.lookup fn (vsFlags vs) of-          Nothing    -> return () -- flag assignment not yet known-          Just True  -> go t t'-          Just False -> go f f'-      (Stanza sn t, ~(Stanza _ t')) -> do-        vs <- get-        case M.lookup sn (vsStanzas vs) of-          Nothing    -> return () -- stanza assignment not yet known-          Just True  -> go t t'-          Just False -> return () -- stanza not enabled; no new deps-    -- For extensions and language dependencies, there is nothing to do.-    -- No choice is involved, just checking, so there is nothing to link.-    -- The same goes for pkg-config constraints.-      (Simple (LDep _ (Ext  _))   _, _) -> return ()-      (Simple (LDep _ (Lang _))   _, _) -> return ()-      (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()--    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)-    requalify deps = do-      vs <- get-      return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)--pickFlag :: QFN -> Bool -> UpdateState ()-pickFlag qfn b = do-    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }-    verifyFlag qfn-    linkNewDeps (F qfn) b--pickStanza :: QSN -> Bool -> UpdateState ()-pickStanza qsn b = do-    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }-    verifyStanza qsn-    linkNewDeps (S qsn) b---- | Link dependencies that we discover after making a flag or stanza choice.------ When we make a flag choice for a package, then new dependencies for that--- package might become available. If the package under consideration is in a--- non-trivial link group, then these new dependencies have to be linked as--- well. In linkNewDeps, we compute such new dependencies and make sure they are--- linked.-linkNewDeps :: Var QPN -> Bool -> UpdateState ()-linkNewDeps var b = do-    vs <- get-    let qpn@(Q pp pn)           = varPN var-        qdeps                   = vsSaved vs ! qpn-        lg                      = vsLinks vs ! qpn-        newDeps                 = findNewDeps vs qdeps-        linkedTo                = S.delete pp (lgMembers lg)-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps-  where-    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN-    findNewDeps vs = concatMap (findNewDeps' vs)--    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN-    findNewDeps' _  (Simple _ _)        = []-    findNewDeps' vs (Flagged qfn _ t f) =-      case (F qfn == var, M.lookup qfn (vsFlags vs)) of-        (True, _)    -> if b then t else f-        (_, Nothing) -> [] -- not yet known-        (_, Just b') -> findNewDeps vs (if b' then t else f)-    findNewDeps' vs (Stanza qsn t) =-      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of-        (True, _)    -> if b then t else []-        (_, Nothing) -> [] -- not yet known-        (_, Just b') -> findNewDeps vs (if b' then t else [])--updateLinkGroup :: LinkGroup -> UpdateState ()-updateLinkGroup lg = do-    verifyLinkGroup lg-    modify $ \vs -> vs {-        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))-                  `M.union` vsLinks vs-      }-  where-    aux pp = (Q pp (lgPackage lg), lg)--{--------------------------------------------------------------------------------  Verification--------------------------------------------------------------------------------}--verifyLinkGroup :: LinkGroup -> UpdateState ()-verifyLinkGroup lg =-    case lgInstance lg of-      -- No instance picked yet. Nothing to verify-      Nothing ->-        return ()--      -- We picked an instance. Verify flags and stanzas-      -- TODO: The enumeration of OptionalStanza names is very brittle;-      -- if a constructor is added to the datatype we won't notice it here-      Just i -> do-        vs <- get-        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i-            flags   = M.keys finfo-            stanzas = [TestStanzas, BenchStanzas]-        forM_ flags $ \fn -> do-          let flag = FN (lgPackage lg) fn-          verifyFlag' flag lg-        forM_ stanzas $ \sn -> do-          let stanza = SN (lgPackage lg) sn-          verifyStanza' stanza lg--verifyFlag :: QFN -> UpdateState ()-verifyFlag (FN qpn@(Q _pp pn) fn) = do-    vs <- get-    -- We can only pick a flag after picking an instance; link group must exist-    verifyFlag' (FN pn fn) (vsLinks vs ! qpn)--verifyStanza :: QSN -> UpdateState ()-verifyStanza (SN qpn@(Q _pp pn) sn) = do-    vs <- get-    -- We can only pick a stanza after picking an instance; link group must exist-    verifyStanza' (SN pn sn) (vsLinks vs ! qpn)---- | Verify that all packages in the link group agree on flag assignments------ For the given flag and the link group, obtain all assignments for the flag--- that have already been made for link group members, and check that they are--- equal.-verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()-verifyFlag' (FN pn fn) lg = do-    vs <- get-    let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))-        vals  = map (`M.lookup` vsFlags vs) flags-    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags-      then return ()-      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg-                    , "flag \"" ++ unFlagName fn ++ "\" incompatible"-                    )---- | Verify that all packages in the link group agree on stanza assignments------ For the given stanza and the link group, obtain all assignments for the--- stanza that have already been made for link group members, and check that--- they are equal.------ This function closely mirrors 'verifyFlag''.-verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()-verifyStanza' (SN pn sn) lg = do-    vs <- get-    let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))-        vals    = map (`M.lookup` vsStanzas vs) stanzas-    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas-      then return ()-      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg-                    , "stanza \"" ++ showStanza sn ++ "\" incompatible"-                    )--{--------------------------------------------------------------------------------  Link groups--------------------------------------------------------------------------------}---- | Set of packages that must be linked together------ A LinkGroup is between several qualified package names. In the validation--- state, we maintain a map vsLinks from qualified package names to link groups.--- There is an invariant that for all members of a link group, vsLinks must map--- to the same link group. The function updateLinkGroup can be used to--- re-establish this invariant after creating or expanding a LinkGroup.-data LinkGroup = LinkGroup {-      -- | The name of the package of this link group-      lgPackage :: PN--      -- | The canonical member of this link group (the one where we picked-      -- a concrete instance). Once we have picked a canonical member, all-      -- other packages must link to this one.-      ---      -- We may not know this yet (if we are constructing link groups-      -- for dependencies)-    , lgCanon :: Maybe (PI PackagePath)--      -- | The members of the link group-    , lgMembers :: Set PackagePath--      -- | The set of variables that should be added to the conflict set if-      -- something goes wrong with this link set (in addition to the members-      -- of the link group itself)-    , lgBlame :: ConflictSet-    }-    deriving (Show, Eq)---- | Invariant for the set of link groups: every element in the link group--- must be pointing to the /same/ link group-lgInvariant :: Map QPN LinkGroup -> Bool-lgInvariant links = all invGroup (M.elems links)-  where-    invGroup :: LinkGroup -> Bool-    invGroup lg = allEqual $ map (`M.lookup` links) members-      where-        members :: [QPN]-        members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)---- | Package version of this group------ This is only known once we have picked a canonical element.-lgInstance :: LinkGroup -> Maybe I-lgInstance = fmap (\(PI _ i) -> i) . lgCanon--showLinkGroup :: LinkGroup -> String-showLinkGroup lg =-    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"-  where-    showMember :: PackagePath -> String-    showMember pp = case lgCanon lg of-                      Just (PI pp' _i) | pp == pp' -> "*"-                      _otherwise                   -> ""-                 ++ case lgInstance lg of-                      Nothing -> showQPN (qpn pp)-                      Just i  -> showPI (PI (qpn pp) i)--    qpn :: PackagePath -> QPN-    qpn pp = Q pp (lgPackage lg)---- | Creates a link group that contains a single member.-lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup-lgSingleton (Q pp pn) canon = LinkGroup {-      lgPackage = pn-    , lgCanon   = canon-    , lgMembers = S.singleton pp-    , lgBlame   = CS.empty-    }--lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup-lgMerge blame lg lg' = do-    canon <- pick (lgCanon lg) (lgCanon lg')-    return LinkGroup {-        lgPackage = lgPackage lg-      , lgCanon   = canon-      , lgMembers = lgMembers lg `S.union` lgMembers lg'-      , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']-      }-  where-    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)-    pick Nothing  Nothing  = Right Nothing-    pick (Just x) Nothing  = Right $ Just x-    pick Nothing  (Just y) = Right $ Just y-    pick (Just x) (Just y) =-      if x == y then Right $ Just x-                else Left ( CS.unions [-                               blame-                             , lgConflictSet lg-                             , lgConflictSet lg'-                             ]-                          ,    "cannot merge " ++ showLinkGroup lg-                            ++ " and " ++ showLinkGroup lg'-                          )--lgConflictSet :: LinkGroup -> ConflictSet-lgConflictSet lg =-               CS.fromList (map aux (S.toList (lgMembers lg)))-    `CS.union` lgBlame lg-  where-    aux pp = P (Q pp (lgPackage lg))--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}--allEqual :: Eq a => [a] -> Bool-allEqual []       = True-allEqual [_]      = True-allEqual (x:y:ys) = x == y && allEqual (y:ys)
− cabal-install-solver/src/Distribution/Solver/Modular/Log.hs 
@@ -1,31 +0,0 @@-module Distribution.Solver.Modular.Log-    ( displayLogMessages-    , SolverFailure(..)-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude--import Distribution.Solver.Types.Progress--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.RetryLog---- | Information about a dependency solver failure.-data SolverFailure =-    ExhaustiveSearch ConflictSet ConflictMap-  | BackjumpLimitReached---- | Postprocesses a log file. This function discards all log messages and--- avoids calling 'showMessages' if the log isn't needed (specified by--- 'keepLog'), for efficiency.-displayLogMessages :: Bool-                   -> RetryLog Message SolverFailure a-                   -> RetryLog String SolverFailure a-displayLogMessages keepLog lg = fromProgress $-    if keepLog-    then showMessages progress-    else foldProgress (const id) Fail Done progress-  where-    progress = toProgress lg
− cabal-install-solver/src/Distribution/Solver/Modular/Message.hs 
@@ -1,271 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Distribution.Solver.Modular.Message (-    Message(..),-    showMessages-  ) where--import qualified Data.List as L-import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S-import Data.Maybe (catMaybes, mapMaybe)-import Prelude hiding (pi)--import Distribution.Pretty (prettyShow) -- from Cabal--import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-         ( FailReason(..), POption(..), ConflictingDep(..) )-import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Progress-import Distribution.Types.LibraryName-import Distribution.Types.UnqualComponentName--data Message =-    Enter           -- ^ increase indentation level-  | Leave           -- ^ decrease indentation level-  | TryP QPN POption-  | TryF QFN Bool-  | TryS QSN Bool-  | Next (Goal QPN)-  | Skip (Set CS.Conflict)-  | Success-  | Failure ConflictSet FailReason---- | Transforms the structured message type to actual messages (strings).------ The log contains level numbers, which are useful for any trace that involves--- backtracking, because only the level numbers will allow to keep track of--- backjumps.-showMessages :: Progress Message a b -> Progress String a b-showMessages = go 0-  where-    -- 'go' increments the level for a recursive call when it encounters-    -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.-    go :: Int -> Progress Message a b -> Progress String a b-    go !_ (Done x)                           = Done x-    go !_ (Fail x)                           = Fail x-    -- complex patterns-    go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        goPReject l qpn [i] c fr ms-    go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =-        goPSkip l qpn [i] conflicts ms-    go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)-    go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)-    go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)-    go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =-        (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms-    -- standard display-    go !l (Step Enter                    ms) = go (l+1) ms-    go !l (Step Leave                    ms) = go (l-1) ms-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)-    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)-    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log-    go !l (Step (Skip conflicts)         ms) =-        -- 'Skip' should always be handled by 'goPSkip' in the case above.-        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)-    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)-    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)--    showPackageGoal :: QPN -> QGoalReason -> String-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr--    showFailure :: ConflictSet -> FailReason -> String-    showFailure c fr = "fail" ++ showFR c fr--    -- special handler for many subsequent package rejections-    goPReject :: Int-              -> QPN-              -> [POption]-              -> ConflictSet-              -> FailReason-              -> Progress Message a b-              -> Progress String a b-    goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms-    goPReject l qpn is c fr ms =-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)--    -- Handle many subsequent skipped package instances.-    goPSkip :: Int-            -> QPN-            -> [POption]-            -> Set CS.Conflict-            -> Progress Message a b-            -> Progress String a b-    goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))-      | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms-    goPSkip l qpn is conflicts ms =-      let msg = "skipping: "-                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))-                 ++ showConflicts conflicts-      in atLevel l msg (go l ms)--    -- write a message with the current level number-    atLevel :: Int -> String -> Progress String a b -> Progress String a b-    atLevel l x xs =-      let s = show l-      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs---- | Display the set of 'Conflicts' for a skipped package version.-showConflicts :: Set CS.Conflict -> String-showConflicts conflicts =-    " (has the same characteristics that caused the previous version to fail: "-     ++ conflictMsg ++ ")"-  where-    conflictMsg :: String-    conflictMsg =-      if S.member CS.OtherConflict conflicts-      then-        -- This case shouldn't happen, because an unknown conflict should not-        -- cause a version to be skipped.-        "unknown conflict"-      else let mergedConflicts =-                   [ showConflict qpn conflict-                   | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]-           in if L.null mergedConflicts-              then-                  -- This case shouldn't happen unless backjumping is turned off.-                  "none"-              else L.intercalate "; " mergedConflicts--    -- Merge conflicts to simplify the log message.-    mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict-    mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList-      where-        mergeConflict :: MergedPackageConflict-                      -> MergedPackageConflict-                      -> MergedPackageConflict-        mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {-              isGoalConflict =-                  isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2-            , versionConstraintConflict =-                  L.nub $ versionConstraintConflict mergedConflict1-                       ++ versionConstraintConflict mergedConflict2-            , versionConflict =-                  mergeVersionConflicts (versionConflict mergedConflict1)-                                        (versionConflict mergedConflict2)-            }-          where-            mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)-            mergeVersionConflicts (Just vr1) Nothing    = Just vr1-            mergeVersionConflicts Nothing    (Just vr2) = Just vr2-            mergeVersionConflicts Nothing    Nothing    = Nothing--        toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)-        toMergedConflict (CS.GoalConflict qpn) =-            Just (qpn, MergedPackageConflict True [] Nothing)-        toMergedConflict (CS.VersionConstraintConflict qpn v) =-            Just (qpn, MergedPackageConflict False [v] Nothing)-        toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =-            Just (qpn, MergedPackageConflict False [] (Just vr))-        toMergedConflict CS.OtherConflict = Nothing--    showConflict :: QPN -> MergedPackageConflict -> String-    showConflict qpn mergedConflict = L.intercalate "; " conflictStrings-      where-        conflictStrings = catMaybes [-            case () of-              () | isGoalConflict mergedConflict -> Just $-                     "depends on '" ++ showQPN qpn ++ "'" ++-                         (if null (versionConstraintConflict mergedConflict)-                          then ""-                          else " but excludes "-                                ++ showVersions (versionConstraintConflict mergedConflict))-                 | not $ L.null (versionConstraintConflict mergedConflict) -> Just $-                     "excludes '" ++ showQPN qpn-                      ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)-                 | otherwise -> Nothing-          , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")-             <$> versionConflict mergedConflict-          ]--        showVersions []  = "no versions"-        showVersions [v] = "version " ++ showVer v-        showVersions vs  = "versions " ++ L.intercalate ", " (map showVer vs)---- | All conflicts related to one package, used for simplifying the display of--- a 'Set CS.Conflict'.-data MergedPackageConflict = MergedPackageConflict {-    isGoalConflict :: Bool-  , versionConstraintConflict :: [Ver]-  , versionConflict :: Maybe VR-  }--showQPNPOpt :: QPN -> POption -> String-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =-  case linkedTo of-    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption-    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)--showGR :: QGoalReason -> String-showGR UserGoal            = " (user goal)"-showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"--showFR :: ConflictSet -> FailReason -> String-showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ prettyShow ext ++ ")"-showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ prettyShow lang ++ ")"-showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"-showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"-showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"-showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"-showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"-showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")"-showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"-showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"-showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"-showFR _ CannotInstall                    = " (only already installed instances can be used)"-showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"-showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"-showFR _ Shadowed                         = " (shadowed by another installed package with same version)"-showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"-showFR _ UnknownPackage                   = " (unknown package)"-showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"-showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"-showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"-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 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 ++ ")"--- The following are internal failures. They should not occur. In the--- interest of not crashing unnecessarily, we still just print an error--- message though.-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"-showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"--showExposedComponent :: ExposedComponent -> String-showExposedComponent (ExposedLib LMainLibName)       = "library"-showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"-showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"--constraintSource :: ConstraintSource -> String-constraintSource src = "constraint from " ++ showConstraintSource src--showConflictingDep :: ConflictingDep -> String-showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =-  let DependencyReason qpn' _ _ = dr-      componentStr = case comp of-                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"-                       ExposedLib LMainLibName      -> ""-                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"-  in case ci of-       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++-                         showQPN qpn ++ componentStr ++ "==" ++ showI i-       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++-                         componentStr ++ showVR vr
− cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Solver.Modular.PSQ-    ( PSQ(..)  -- Unit test needs constructor access-    , casePSQ-    , cons-    , length-    , lookup-    , filter-    , filterIfAny-    , filterIfAnyByKeys-    , filterKeys-    , firstOnly-    , fromList-    , isZeroOrOne-    , keys-    , map-    , mapKeys-    , mapWithKey-    , maximumBy-    , minimumBy-    , null-    , prefer-    , preferByKeys-    , snoc-    , sortBy-    , sortByKeys-    , toList-    , union-    ) where---- Priority search queues.------ I am not yet sure what exactly is needed. But we need a data structure with--- key-based lookup that can be sorted. We're using a sequence right now with--- (inefficiently implemented) lookup, because I think that queue-based--- operations and sorting turn out to be more efficiency-critical in practice.--import Control.Arrow (first, second)--import qualified Data.Foldable as F-import Data.Function-import qualified Data.List as S-import Data.Ord (comparing)-import Data.Traversable-import Prelude hiding (foldr, length, lookup, filter, null, map)--newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP--keys :: PSQ k v -> [k]-keys (PSQ xs) = fmap fst xs--lookup :: Eq k => k -> PSQ k v -> Maybe v-lookup k (PSQ xs) = S.lookup k xs--map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2-map f (PSQ xs) = PSQ (fmap (second f) xs)--mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v-mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)--mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b-mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)--fromList :: [(k, a)] -> PSQ k a-fromList = PSQ--cons :: k -> a -> PSQ k a -> PSQ k a-cons k x (PSQ xs) = PSQ ((k, x) : xs)--snoc :: PSQ k a -> k -> a -> PSQ k a-snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])--casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r-casePSQ (PSQ xs) n c =-  case xs of-    []          -> n-    (k, v) : ys -> c k v (PSQ ys)--sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a-sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)--sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a-sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)--maximumBy :: (k -> Int) -> PSQ k a -> (k, a)-maximumBy sel (PSQ xs) =-  S.minimumBy (flip (comparing (sel . fst))) xs--minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a-minimumBy sel (PSQ xs) =-  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]---- | Sort the list so that values satisfying the predicate are first.-prefer :: (a -> Bool) -> PSQ k a -> PSQ k a-prefer p = sortBy $ flip (comparing p)---- | Sort the list so that keys satisfying the predicate are first.-preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-preferByKeys p = sortByKeys $ flip (comparing p)---- | Will partition the list according to the predicate. If--- there is any element that satisfies the precidate, then only--- the elements satisfying the predicate are returned.--- Otherwise, the rest is returned.----filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a-filterIfAny p (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then PSQ con else PSQ pro---- | Variant of 'filterIfAny' that takes a predicate on the keys--- rather than on the values.----filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-filterIfAnyByKeys p (PSQ xs) =-  let-    (pro, con) = S.partition (p . fst) xs-  in-    if S.null pro then PSQ con else PSQ pro--filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)--filter :: (a -> Bool) -> PSQ k a -> PSQ k a-filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)--length :: PSQ k a -> Int-length (PSQ xs) = S.length xs--null :: PSQ k a -> Bool-null (PSQ xs) = S.null xs--isZeroOrOne :: PSQ k a -> Bool-isZeroOrOne (PSQ [])  = True-isZeroOrOne (PSQ [_]) = True-isZeroOrOne _         = False--firstOnly :: PSQ k a -> PSQ k a-firstOnly (PSQ [])      = PSQ []-firstOnly (PSQ (x : _)) = PSQ [x]--toList :: PSQ k a -> [(k, a)]-toList (PSQ xs) = xs--union :: PSQ k a -> PSQ k a -> PSQ k a-union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)
− cabal-install-solver/src/Distribution/Solver/Modular/Package.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Package-  ( I(..)-  , Loc(..)-  , PackageId-  , PackageIdentifier(..)-  , PackageName, mkPackageName, unPackageName-  , PkgconfigName, mkPkgconfigName, unPkgconfigName-  , PI(..)-  , PN-  , QPV-  , instI-  , makeIndependent-  , primaryPP-  , setupPP-  , showI-  , showPI-  , unPN-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude--import Distribution.Package -- from Cabal-import Distribution.Pretty (prettyShow)--import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.PackagePath---- | A package name.-type PN = PackageName---- | Unpacking a package name.-unPN :: PN -> String-unPN = unPackageName---- | Package version. A package name plus a version number.-type PV = PackageId---- | Qualified package version.-type QPV = Qualified PV---- | Package id. Currently just a black-box string.-type PId = UnitId---- | Location. Info about whether a package is installed or not, and where--- exactly it is located. For installed packages, uniquely identifies the--- package instance via its 'PId'.------ TODO: More information is needed about the repo.-data Loc = Inst PId | InRepo-  deriving (Eq, Ord, Show)---- | Instance. A version number and a location.-data I = I Ver Loc-  deriving (Eq, Ord, Show)---- | String representation of an instance.-showI :: I -> String-showI (I v InRepo)   = showVer v-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid-  where-    extractPackageAbiHash xs =-      case first reverse $ break (=='-') $ reverse (prettyShow xs) of-        (ys, []) -> ys-        (ys, _)  -> '-' : ys---- | Package instance. A package name and an instance.-data PI qpn = PI qpn I-  deriving (Eq, Ord, Show, Functor)---- | String representation of a package instance.-showPI :: PI QPN -> String-showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i--instI :: I -> Bool-instI (I _ (Inst _)) = True-instI _              = False---- | Is the package in the primary group of packages.  This is used to--- determine (1) if we should try to establish stanza preferences--- for this goal, and (2) whether or not a user specified @--constraint@--- should apply to this dependency (grep 'primaryPP' to see the--- use sites).  In particular this does not include packages pulled in--- as setup deps.----primaryPP :: PackagePath -> Bool-primaryPP (PackagePath _ns q) = go q-  where-    go QualToplevel    = True-    go (QualBase  _)   = True-    go (QualSetup _)   = False-    go (QualExe _ _)   = False---- | Is the package a dependency of a setup script.  This is used to--- establish whether or not certain constraints should apply to this--- dependency (grep 'setupPP' to see the use sites).----setupPP :: PackagePath -> Bool-setupPP (PackagePath _ns (QualSetup _)) = True-setupPP (PackagePath _ns _)         = False---- | Qualify a target package with its own name so that its dependencies are not--- required to be consistent with other targets.-makeIndependent :: PN -> QPN-makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn
− cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs 
@@ -1,482 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Reordering or pruning the tree in order to prefer or make certain choices.-module Distribution.Solver.Modular.Preference-    ( avoidReinstalls-    , deferSetupExeChoices-    , deferWeakFlagChoices-    , enforceManualFlags-    , enforcePackageConstraints-    , enforceSingleInstanceRestriction-    , firstGoal-    , preferBaseGoalChoice-    , preferLinked-    , preferPackagePreferences-    , preferReallyEasyGoalChoices-    , requireInstalled-    , onlyConstrained-    , sortGoals-    , pruneAfterFirstSuccess-    ) where--import Prelude ()-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 Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal--import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.InstalledPreference-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.Variable--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W---- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a--- list of weight-calculating functions in order to avoid sorting the package--- choices multiple times. Each function takes the package name, sorted list of--- children's versions, and package option. 'addWeights' prepends the new--- weights to the existing weights, which gives precedence to preferences that--- are applied later.-addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c-addWeights fs = trav go-  where-    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)-    go (PChoiceF qpn@(Q _ pn) rdm x cs) =-      let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)-          weights k = [f pn sortedVersions k | f <- fs]--          elemsToWhnf :: [a] -> ()-          elemsToWhnf = foldr seq ()-      in  PChoiceF qpn rdm x-          -- Evaluate the children's versions before evaluating any of the-          -- subtrees, so that 'sortedVersions' doesn't hold onto all of the-          -- subtrees (referenced by cs) and cause a space leak.-          (elemsToWhnf sortedVersions `seq`-             W.mapWeightsWithKey (\k w -> weights k ++ w) cs)-    go x                            = x--addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c-addWeight f = addWeights [f]--version :: POption -> Ver-version (POption (I v _) _) = v---- | Prefer to link packages whenever possible.-preferLinked :: Tree d c -> Tree d c-preferLinked = addWeight (const (const linked))-  where-    linked (POption _ Nothing)  = 1-    linked (POption _ (Just _)) = 0---- Works by setting weights on choice nodes. Also applies stanza preferences.-preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c-preferPackagePreferences pcs =-    preferPackageStanzaPreferences pcs .-    addWeights [-          \pn _  opt -> preferred pn opt--        -- Note that we always rank installed before uninstalled, and later-        -- versions before earlier, but we can change the priority of the-        -- two orderings.-        , \pn vs opt -> case preference pn of-                          PreferInstalled -> installed opt-                          PreferLatest    -> latest vs opt-        , \pn vs opt -> case preference pn of-                          PreferInstalled -> latest vs opt-                          PreferLatest    -> installed opt-        ]-  where-    -- Prefer packages with higher version numbers over packages with-    -- lower version numbers.-    latest :: [Ver] -> POption -> Weight-    latest sortedVersions opt =-      let l = length sortedVersions-          index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions-      in  fromIntegral index / fromIntegral l--    preference :: PN -> InstalledPreference-    preference pn =-      let PackagePreferences _ ipref _ = pcs pn-      in  ipref--    -- | Prefer versions satisfying more preferred version ranges.-    preferred :: PN -> POption -> Weight-    preferred pn opt =-      let PackagePreferences vrs _ _ = pcs pn-      in fromIntegral . negate . L.length $-         L.filter (flip checkVR (version opt)) vrs--    -- Prefer installed packages over non-installed packages.-    installed :: POption -> Weight-    installed (POption (I _ (Inst _)) _) = 0-    installed _                          = 1---- | Traversal that tries to establish package stanza enable\/disable--- preferences. Works by reordering the branches of stanza choices.-preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c-preferPackageStanzaPreferences pcs = trav go-  where-    go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)-      | primaryPP pp && enableStanzaPref pn s =-          -- move True case first to try enabling the stanza-          let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts-              weight k = if k then 0 else 1-          -- defer the choice by setting it to weak-          in  SChoiceF qsn rdm gr (WeakOrTrivial True) ts'-    go x = x--    enableStanzaPref :: PN -> OptionalStanza -> Bool-    enableStanzaPref pn s =-      let PackagePreferences _ _ spref = pcs pn-      in  s `elem` spref---- | Helper function that tries to enforce a single package constraint on a--- given instance for a P-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintP :: forall d c. QPN-                          -> ConflictSet-                          -> I-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go i prop-    else r-  where-    go :: I -> PackageProperty -> Tree d c-    go (I v _) (PackagePropertyVersion vr)-        | checkVR vr v  = r-        | otherwise     = Fail c (GlobalConstraintVersion vr src)-    go _       PackagePropertyInstalled-        | instI i       = r-        | otherwise     = Fail c (GlobalConstraintInstalled src)-    go _       PackagePropertySource-        | not (instI i) = r-        | otherwise     = Fail c (GlobalConstraintSource src)-    go _       _        = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintF :: forall d c. QPN-                          -> Flag-                          -> ConflictSet-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go prop-    else r-  where-    go :: PackageProperty -> Tree d c-    go (PackagePropertyFlags fa) =-        case lookupFlagAssignment f fa of-          Nothing            -> r-          Just b | b == b'   -> r-                 | otherwise -> Fail c (GlobalConstraintFlag src)-    go _                             = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintS :: forall d c. QPN-                          -> OptionalStanza-                          -> ConflictSet-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go prop-    else r-  where-    go :: PackageProperty -> Tree d c-    go (PackagePropertyStanzas ss) =-        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)-                                 else r-    go _                               = r---- | Traversal that tries to establish various kinds of user constraints. Works--- by selectively disabling choices that have been ruled out by global user--- constraints.-enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]-                          -> Tree d c-                          -> Tree d c-enforcePackageConstraints pcs = trav go-  where-    go (PChoiceF qpn@(Q _ pn) rdm gr                    ts) =-      let c = varToConflictSet (P qpn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc)-                                       id-                                       (M.findWithDefault [] pn pcs)-      in PChoiceF qpn rdm gr        (W.mapWithKey g ts)-    go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) =-      let c = varToConflictSet (F qfn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)-                           id-                           (M.findWithDefault [] pn pcs)-      in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)-    go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr   ts) =-      let c = varToConflictSet (S qsn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)-                           id-                           (M.findWithDefault [] pn pcs)-      in SChoiceF qsn rdm gr tr     (W.mapWithKey g ts)-    go x = x---- | Transformation that tries to enforce the rule that manual flags can only be--- set by the user.------ If there are no constraints on a manual flag, this function prunes all but--- the default value. If there are constraints, then the flag is allowed to have--- the values specified by the constraints. Note that the type used for flag--- values doesn't need to be Bool.------ This function makes an exception for the case where there are multiple goals--- for a single package (with different qualifiers), and flag constraints for--- manual flag x only apply to some of those goals. In that case, we allow the--- unconstrained goals to use the default value for x OR any of the values in--- the constraints on x (even though the constraints don't apply), in order to--- allow the unconstrained goals to be linked to the constrained goals. See--- https://github.com/haskell/cabal/issues/4299. Removing the single instance--- restriction (SIR) would also fix #4299, so we may want to remove this--- exception and only let the user toggle manual flags if we remove the SIR.------ This function does not enforce any of the constraints, since that is done by--- 'enforcePackageConstraints'.-enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c-enforceManualFlags pcs = trav go-  where-    go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =-        FChoiceF qfn rdm gr tr Manual d $-          let -- A list of all values specified by constraints on 'fn'.-              -- We ignore the constraint scope in order to handle issue #4299.-              flagConstraintValues :: [Bool]-              flagConstraintValues =-                  [ flagVal-                  | let lpcs = M.findWithDefault [] pn pcs-                  , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs-                  , (fn', flagVal) <- unFlagAssignment fa-                  , fn' == fn ]--              -- Prune flag values that are not the default and do not match any-              -- of the constraints.-              restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c-              restrictToggling flagDefault constraintVals flagVal r =-                  if flagVal `elem` constraintVals || flagVal == flagDefault-                  then r-                  else Fail (varToConflictSet (F qfn)) ManualFlag--      in W.mapWithKey (restrictToggling d flagConstraintValues) ts-    go x                                                            = x---- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c-requireInstalled p = trav go-  where-    go (PChoiceF v@(Q _ pn) rdm gr cs)-      | p pn      = PChoiceF v rdm gr (W.mapWithKey installed cs)-      | otherwise = PChoiceF v rdm gr                         cs-      where-        installed (POption (I _ (Inst _)) _) x = x-        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall-    go x          = x---- | Avoid reinstalls.------ This is a tricky strategy. If a package version is installed already and the--- same version is available from a repo, the repo version will never be chosen.--- This would result in a reinstall (either destructively, or potentially,--- shadowing). The old instance won't be visible or even present anymore, but--- other packages might have depended on it.------ TODO: It would be better to actually check the reverse dependencies of installed--- packages. If they're not depended on, then reinstalling should be fine. Even if--- they are, perhaps this should just result in trying to reinstall those other--- packages as well. However, doing this all neatly in one pass would require to--- change the builder, or at least to change the goal set after building.-avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c-avoidReinstalls p = trav go-  where-    go (PChoiceF qpn@(Q _ pn) rdm gr cs)-      | p pn      = PChoiceF qpn rdm gr disableReinstalls-      | otherwise = PChoiceF qpn rdm gr cs-      where-        disableReinstalls =-          let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]-          in  W.mapWithKey (notReinstall installed) cs--        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =-          Fail (varToConflictSet (P qpn)) CannotReinstall-        notReinstall _ _ x =-          x-    go x          = x---- | Require all packages to be mentioned in a constraint or as a goal.-onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason-onlyConstrained p = trav go-  where-    go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)-      = FailF-        (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr)-        NotExplicit-    go x-      = x---- | Sort all goals using the provided function.-sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c-sortGoals variableOrder = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs)-    go x                    = x--    goalOrder :: Goal QPN -> Goal QPN -> Ordering-    goalOrder = variableOrder `on` (varToVariable . goalToVar)--    varToVariable :: Var QPN -> Variable QPN-    varToVariable (P qpn)                    = PackageVar qpn-    varToVariable (F (FN qpn fn))     = FlagVar qpn fn-    varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza---- | Reduce the branching degree of the search tree by removing all choices--- after the first successful choice at each level. The returned tree is the--- minimal subtree containing the path to the first backjump.-pruneAfterFirstSuccess :: Tree d c -> Tree d c-pruneAfterFirstSuccess = trav go-  where-    go (PChoiceF qpn rdm gr       ts) = PChoiceF qpn rdm gr       (W.takeUntil active ts)-    go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts)-    go (SChoiceF qsn rdm gr w     ts) = SChoiceF qsn rdm gr w     (W.takeUntil active ts)-    go x                              = x---- | Always choose the first goal in the list next, abandoning all--- other choices.------ This is unnecessary for the default search strategy, because--- it descends only into the first goal choice anyway,--- but may still make sense to just reduce the tree size a bit.-firstGoal :: Tree d c -> Tree d c-firstGoal = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs)-    go x                    = x-    -- Note that we keep empty choice nodes, because they mean success.---- | Transformation that tries to make a decision on base as early as--- possible by pruning all other goals when base is available. In nearly--- all cases, there's a single choice for the base package. Also, fixing--- base early should lead to better error messages.-preferBaseGoalChoice :: Tree d c -> Tree d c-preferBaseGoalChoice = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs)-    go x                    = x--    isBase :: Goal QPN -> Bool-    isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base"-    isBase _                       = False---- | Deal with setup and build-tool-depends dependencies after regular dependencies,--- so we will link setup/exe dependencies against package dependencies when possible-deferSetupExeChoices :: Tree d c -> Tree d c-deferSetupExeChoices = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs)-    go x                    = x--    noSetupOrExe :: Goal QPN -> Bool-    noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False-    noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False-    noSetupOrExe _                                                  = True---- | Transformation that tries to avoid making weak flag choices early.--- Weak flags are trivial flags (not influencing dependencies) or such--- flags that are explicitly declared to be weak in the index.-deferWeakFlagChoices :: Tree d c -> Tree d c-deferWeakFlagChoices = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs))-    go x                    = x--    noWeakStanza :: Tree d c -> Bool-    noWeakStanza (SChoice _ _ _ (WeakOrTrivial True)   _) = False-    noWeakStanza _                                        = True--    noWeakFlag :: Tree d c -> Bool-    noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False-    noWeakFlag _                                          = True---- | Transformation that prefers goals with lower branching degrees.------ When a goal choice node has at least one goal with zero or one children, this--- function prunes all other goals. This transformation can help the solver find--- a solution in fewer steps by allowing it to backtrack sooner when it is--- exploring a subtree with no solutions. However, each step is more expensive.-preferReallyEasyGoalChoices :: Tree d c -> Tree d c-preferReallyEasyGoalChoices = trav go-  where-    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) . cata go-  where-    go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)--    -- We just verify package choices.-    go (PChoiceF qpn rdm gr cs) =-      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs)-    go _otherwise =-      innM _otherwise--    -- 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
− cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Distribution.Solver.Modular.RetryLog-    ( RetryLog-    , toProgress-    , fromProgress-    , mapFailure-    , retry-    , failWith-    , succeedWith-    , continueWith-    , tryWith-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Modular.Message-import Distribution.Solver.Types.Progress---- | 'Progress' as a difference list that allows efficient appends at failures.-newtype RetryLog step fail done = RetryLog {-    unRetryLog :: forall fail2 . (fail -> Progress step fail2 done)-               -> Progress step fail2 done-  }---- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.-toProgress :: RetryLog step fail done -> Progress step fail done-toProgress (RetryLog f) = f Fail---- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.-fromProgress :: Progress step fail done -> RetryLog step fail done-fromProgress l = RetryLog $ \f -> go f l-  where-    go :: (fail1 -> Progress step fail2 done)-       -> Progress step fail1 done-       -> Progress step fail2 done-    go _ (Done d) = Done d-    go f (Fail failure) = f failure-    go f (Step m ms) = Step m (go f ms)---- | /O(1)/. Apply a function to the failure value in a log.-mapFailure :: (fail1 -> fail2)-           -> RetryLog step fail1 done-           -> RetryLog step fail2 done-mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure)---- | /O(1)/. If the first log leads to failure, continue with the second.-retry :: RetryLog step fail1 done-      -> (fail1 -> RetryLog step fail2 done)-      -> RetryLog step fail2 done-retry (RetryLog f) g =-    RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog---- | /O(1)/. Create a log with one message before a failure.-failWith :: step -> fail -> RetryLog step fail done-failWith m failure = RetryLog $ \f -> Step m (f failure)---- | /O(1)/. Create a log with one message before a success.-succeedWith :: step -> done -> RetryLog step fail done-succeedWith m d = RetryLog $ const $ Step m (Done d)---- | /O(1)/. Prepend a message to a log.-continueWith :: step-             -> RetryLog step fail done-             -> RetryLog step fail done-continueWith m (RetryLog f) = RetryLog $ Step m . f---- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert--- 'Leave' before the failure if the log fails.-tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done-tryWith m f =-  RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))
− cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef DEBUG_TRACETREE-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif-module Distribution.Solver.Modular.Solver-    ( SolverConfig(..)-    , solve-    , PruneAfterFirstSuccess(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Data.Map as M-import qualified Data.List as L-import qualified Data.Set as S-import Distribution.Verbosity--import Distribution.Compiler (CompilerInfo)--import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.Settings-import Distribution.Solver.Types.Variable--import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Builder-import Distribution.Solver.Modular.Cycles-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Explore-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Log-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.Preference as P-import Distribution.Solver.Modular.Validate-import Distribution.Solver.Modular.Linking-import Distribution.Solver.Modular.PSQ (PSQ)-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.PSQ as PSQ--import Distribution.Simple.Setup (BooleanFlag(..))--#ifdef DEBUG_TRACETREE-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import qualified Distribution.Deprecated.Text as T--import Debug.Trace.Tree (gtraceJson)-import Debug.Trace.Tree.Simple-import Debug.Trace.Tree.Generic-import Debug.Trace.Tree.Assoc (Assoc(..))-#endif---- | Various options for the modular solver.-data SolverConfig = SolverConfig {-  reorderGoals           :: ReorderGoals,-  countConflicts         :: CountConflicts,-  fineGrainedConflicts   :: FineGrainedConflicts,-  minimizeConflictSet    :: MinimizeConflictSet,-  independentGoals       :: IndependentGoals,-  avoidReinstalls        :: AvoidReinstalls,-  shadowPkgs             :: ShadowPkgs,-  strongFlags            :: StrongFlags,-  allowBootLibInstalls   :: AllowBootLibInstalls,-  onlyConstrained        :: OnlyConstrained,-  maxBackjumps           :: Maybe Int,-  enableBackjumping      :: EnableBackjumping,-  solveExecutables       :: SolveExecutables,-  goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),-  solverVerbosity        :: Verbosity,-  pruneAfterFirstSuccess :: PruneAfterFirstSuccess-}---- | Whether to remove all choices after the first successful choice at each--- level in the search tree.-newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool---- | Run all solver phases.------ In principle, we have a valid tree after 'validationPhase', which--- means that every 'Done' node should correspond to valid solution.------ There is one exception, though, and that is cycle detection, which--- has been added relatively recently. Cycles are only removed directly--- before exploration.----solve :: SolverConfig                         -- ^ solver parameters-      -> CompilerInfo-      -> Index                                -- ^ all available packages as an index-      -> PkgConfigDb                          -- ^ available pkg-config pkgs-      -> (PN -> PackagePreferences)           -- ^ preferences-      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints-      -> S.Set PN                             -- ^ global goals-      -> RetryLog Message SolverFailure (Assignment, RevDepMap)-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =-  explorePhase     $-  detectCycles     $-  heuristicsPhase  $-  preferencesPhase $-  validationPhase  $-  prunePhase       $-  buildPhase-  where-    explorePhase     = backjumpAndExplore (maxBackjumps sc)-                                          (enableBackjumping sc)-                                          (fineGrainedConflicts sc)-                                          (countConflicts sc)-                                          idx-    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase-    heuristicsPhase  =-      let heuristicsTree = traceTree "heuristics.json" id-          sortGoals = case goalOrder sc of-                        Nothing -> goalChoiceHeuristics .-                                   heuristicsTree .-                                   P.deferSetupExeChoices .-                                   P.deferWeakFlagChoices .-                                   P.preferBaseGoalChoice-                        Just order -> P.firstGoal .-                                   heuristicsTree .-                                   P.sortGoals order-          PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc-      in sortGoals .-         (if prune then P.pruneAfterFirstSuccess else id)-    preferencesPhase = P.preferLinked .-                       P.preferPackagePreferences userPrefs-    validationPhase  = traceTree "validated.json" id .-                       P.enforcePackageConstraints userConstraints .-                       P.enforceManualFlags userConstraints .-                       P.enforceSingleInstanceRestriction .-                       validateLinking idx .-                       validateTree cinfo idx pkgConfigDB-    prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .-                       (if asBool (allowBootLibInstalls sc)-                        then id-                        else P.requireInstalled (`elem` nonInstallable)) .-                       (case onlyConstrained sc of-                          OnlyConstrainedAll ->-                            P.onlyConstrained pkgIsExplicit-                          OnlyConstrainedNone ->-                            id)-    buildPhase       = traceTree "build.json" id-                     $ buildTree idx (independentGoals sc) (S.toList userGoals)--    allExplicit = M.keysSet userConstraints `S.union` userGoals--    pkgIsExplicit :: PN -> Bool-    pkgIsExplicit pn = S.member pn allExplicit--    -- packages that can never be installed or upgraded-    -- If you change this enumeration, make sure to update the list in-    -- "Distribution.Client.Dependency" as well-    nonInstallable :: [PackageName]-    nonInstallable =-        L.map mkPackageName-             [ "base"-             , "ghc-prim"-             , "integer-gmp"-             , "integer-simple"-             , "template-haskell"-             ]--    -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which-    -- prefers (keeps) goals only if the have 0 or 1 enabled choice.-    ---    -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes-    -- to just a single option. This was a way to work around a space leak that was-    -- unnecessary and is now fixed, so we no longer do it.-    ---    -- If --count-conflicts is active, it will then choose among the remaining goals-    -- the one that has been responsible for the most conflicts so far.-    ---    -- Otherwise, we simply choose the first remaining goal.-    ---    goalChoiceHeuristics-      | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices-      | otherwise                = id {- P.firstGoal -}---- | Dump solver tree to a file (in debugging mode)------ This only does something if the @debug-tracetree@ configure argument was--- given; otherwise this is just the identity function.-traceTree ::-#ifdef DEBUG_TRACETREE-  GSimpleTree a =>-#endif-     FilePath  -- ^ Output file-  -> (a -> a)  -- ^ Function to summarize the tree before dumping-  -> a -> a-#ifdef DEBUG_TRACETREE-traceTree = gtraceJson-#else-traceTree _ _ = id-#endif--#ifdef DEBUG_TRACETREE-instance GSimpleTree (Tree d c) where-  fromGeneric = go-    where-      go :: Tree d c -> SimpleTree-      go (PChoice qpn _ _       psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq-      go (FChoice _   _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq-      go (SChoice _   _ _ _     psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq-      go (GoalChoice  _         psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq-      go (Done _rdm _s)              = Node "D" $ Assoc []-      go (Fail cs _reason)           = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]--      psqToList :: W.WeightedPSQ w k v -> [(k, v)]-      psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList--      -- Show package choice-      goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)-      goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)-      goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)--      -- Show flag or stanza choice-      goFS :: Bool -> Tree d c -> (String, SimpleTree)-      goFS val subtree = (show val, go subtree)--      -- Show goal choice-      goG :: Goal QPN -> Tree d c -> (String, SimpleTree)-      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)--      -- Variation on 'showGR' that produces shorter strings-      -- (Actually, QGoalReason records more info than necessary: we only need-      -- to know the variable that introduced the goal, not the value assigned-      -- to that variable)-      shortGR :: QGoalReason -> String-      shortGR UserGoal            = "user"-      shortGR (DependencyGoal dr) = showDependencyReason dr--      -- Show conflict set-      goCS :: ConflictSet -> String-      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"-#endif---- | Replace all goal reasons with a dummy goal reason in the tree------ This is useful for debugging (when experimenting with the impact of GRs)-_removeGR :: Tree d c -> Tree d QGoalReason-_removeGR = trav go-  where-   go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)-   go (PChoiceF qpn rdm _       psq) = PChoiceF qpn rdm dummy       psq-   go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq-   go (SChoiceF qsn rdm _ a     psq) = SChoiceF qsn rdm dummy a     psq-   go (GoalChoiceF  rdm         psq) = GoalChoiceF  rdm             (goG psq)-   go (DoneF rdm s)                  = DoneF rdm s-   go (FailF cs reason)              = FailF cs reason--   goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)-   goG = PSQ.fromList-       . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))-       . PSQ.toList--   dummy :: QGoalReason-   dummy =-       DependencyGoal $-       DependencyReason-           (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))-           M.empty S.empty
− cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Solver.Modular.Tree-    ( POption(..)-    , Tree(..)-    , TreeF(..)-    , Weight-    , FailReason(..)-    , ConflictingDep(..)-    , ana-    , cata-    , inn-    , innM-    , para-    , trav-    , zeroOrOneChoices-    , active-    ) where--import Control.Monad hiding (mapM, sequence)-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr, mapM, sequence)--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.PSQ (PSQ)-import Distribution.Solver.Modular.Version-import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.PackagePath-import Distribution.Types.PkgconfigVersionRange-import Distribution.Types.UnitId (UnitId)-import Language.Haskell.Extension (Extension, Language)--type Weight = Double---- | Type of the search tree. Inlining the choice nodes for now. Weights on--- package, flag, and stanza choices control the traversal order.------ The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes--- (type 'c'). For example, during the final traversal, choice nodes contain the--- variables that introduced the choices, and 'Done' nodes contain the--- assignments for all variables.------ TODO: The weight type should be changed from [Double] to Double to avoid--- giving too much weight to preferences that are applied later.-data Tree d c =-    -- | Choose a version for a package (or choose to link)-    PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c))--    -- | Choose a value for a flag-    ---    -- The Bool is the default value.-  | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c))--    -- | Choose whether or not to enable a stanza-  | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))--    -- | Choose which choice to make next-    ---    -- Invariants:-    ---    -- * PSQ should never be empty-    -- * For each choice we additionally record the 'QGoalReason' why we are-    --   introducing that goal into tree. Note that most of the time we are-    --   working with @Tree QGoalReason@; in that case, we must have the-    --   invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'-    --   or 'SChoice' directly below a 'GoalChoice' node must equal the reason-    --   recorded on that 'GoalChoice' node.-  | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c))--    -- | We're done -- we found a solution!-  | Done RevDepMap d--    -- | We failed to find a solution in this path through the tree-  | Fail ConflictSet FailReason---- | A package option is a package instance with an optional linking annotation------ The modular solver has a number of package goals to solve for, and can only--- pick a single package version for a single goal. In order to allow to--- install multiple versions of the same package as part of a single solution--- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both--- be qualified goals for @P@, allowing to pick a difference version of package--- @P@ for @0.P@ and @1.P@.------ Linking is an essential part of this story. In addition to picking a specific--- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or--- vice versa). It means that @1.P@ and @0.P@ really must be the very same package--- (and hence must have the same build time configuration, and their--- dependencies must also be the exact same).------ See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.-data POption = POption I (Maybe PackagePath)-  deriving (Eq, Show)--data FailReason = UnsupportedExtension Extension-                | UnsupportedLanguage Language-                | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange-                | NewPackageDoesNotMatchExistingConstraint ConflictingDep-                | ConflictingConstraints ConflictingDep ConflictingDep-                | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)-                | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN)-                | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)-                | PackageRequiresMissingComponent QPN ExposedComponent-                | PackageRequiresPrivateComponent QPN ExposedComponent-                | PackageRequiresUnbuildableComponent QPN ExposedComponent-                | CannotInstall-                | CannotReinstall-                | NotExplicit-                | Shadowed-                | Broken UnitId-                | UnknownPackage-                | GlobalConstraintVersion VR ConstraintSource-                | GlobalConstraintInstalled ConstraintSource-                | GlobalConstraintSource ConstraintSource-                | GlobalConstraintFlag ConstraintSource-                | ManualFlag-                | MalformedFlagChoice QFN-                | MalformedStanzaChoice QSN-                | EmptyGoalChoice-                | Backjump-                | MultipleInstances-                | DependenciesNotLinked String-                | CyclicDependencies-                | UnsupportedSpecVer Ver-  deriving (Eq, Show)---- | Information about a dependency involved in a conflict, for error messages.-data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI-  deriving (Eq, Show)---- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'--- have the same meaning as in 'Tree'.-data TreeF d c a =-    PChoiceF    QPN RevDepMap c                             (WeightedPSQ [Weight] POption a)-  | FChoiceF    QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool    a)-  | SChoiceF    QSN RevDepMap c WeakOrTrivial               (WeightedPSQ [Weight] Bool    a)-  | GoalChoiceF     RevDepMap                               (PSQ (Goal QPN) a)-  | DoneF           RevDepMap d-  | FailF       ConflictSet FailReason-  deriving (Functor, Foldable, Traversable)--out :: Tree d c -> TreeF d c (Tree d c)-out (PChoice    p s i       ts) = PChoiceF    p s i       ts-out (FChoice    p s i b m d ts) = FChoiceF    p s i b m d ts-out (SChoice    p s i b     ts) = SChoiceF    p s i b     ts-out (GoalChoice   s         ts) = GoalChoiceF   s         ts-out (Done       x s           ) = DoneF       x s-out (Fail       c x           ) = FailF       c x--inn :: TreeF d c (Tree d c) -> Tree d c-inn (PChoiceF    p s i       ts) = PChoice    p s i       ts-inn (FChoiceF    p s i b m d ts) = FChoice    p s i b m d ts-inn (SChoiceF    p s i b     ts) = SChoice    p s i b     ts-inn (GoalChoiceF   s         ts) = GoalChoice   s         ts-inn (DoneF       x s           ) = Done       x s-inn (FailF       c x           ) = Fail       c x--innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)-innM (PChoiceF    p s i       ts) = liftM (PChoice    p s i      ) (sequence ts)-innM (FChoiceF    p s i b m d ts) = liftM (FChoice    p s i b m d) (sequence ts)-innM (SChoiceF    p s i b     ts) = liftM (SChoice    p s i b    ) (sequence ts)-innM (GoalChoiceF   s         ts) = liftM (GoalChoice   s        ) (sequence ts)-innM (DoneF       x s           ) = return $ Done     x s-innM (FailF       c x           ) = return $ Fail     c x---- | Determines whether a tree is active, i.e., isn't a failure node.-active :: Tree d c -> Bool-active (Fail _ _) = False-active _          = True---- | Approximates the number of active choices that are available in a node.--- Note that we count goal choices as having one choice, always.-zeroOrOneChoices :: Tree d c -> Bool-zeroOrOneChoices (PChoice    _ _ _       ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (FChoice    _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (SChoice    _ _ _ _     ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (GoalChoice _           _ ) = True-zeroOrOneChoices (Done       _ _           ) = True-zeroOrOneChoices (Fail       _ _           ) = True---- | Catamorphism on trees.-cata :: (TreeF d c a -> a) -> Tree d c -> a-cata phi x = (phi . fmap (cata phi) . out) x--trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a-trav psi x = cata (inn . psi) x---- | Paramorphism on trees.-para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a-para phi = phi . fmap (\ x -> (para phi x, x)) . out---- | Anamorphism on trees.-ana :: (a -> TreeF d c a) -> a -> Tree d c-ana psi = inn . fmap (ana psi) . psi
− cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs 
@@ -1,593 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif-module Distribution.Solver.Modular.Validate (validateTree) where---- Validation of the tree.------ The task here is to make sure all constraints hold. After validation, any--- assignment returned by exploration of the tree should be a complete valid--- assignment, i.e., actually constitute a solution.--import Control.Applicative-import Control.Monad.Reader hiding (sequence)-import Data.Either (lefts)-import Data.Function (on)-import Data.Traversable-import Prelude hiding (sequence)--import qualified Data.List as L-import qualified Data.Set as S--import Language.Haskell.Extension (Extension, Language)--import Data.Map.Strict as M-import Distribution.Compiler (CompilerInfo(..))--import Distribution.Solver.Modular.Assignment-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)-import Distribution.Types.LibraryName-import Distribution.Types.PkgconfigVersionRange--#ifdef DEBUG_CONFLICT_SETS-import GHC.Stack (CallStack)-#endif---- In practice, most constraints are implication constraints (IF we have made--- a number of choices, THEN we also have to ensure that). We call constraints--- that for which the preconditions are fulfilled ACTIVE. We maintain a set--- of currently active constraints that we pass down the node.------ We aim at detecting inconsistent states as early as possible.------ Whenever we make a choice, there are two things that need to happen:------   (1) We must check that the choice is consistent with the currently---       active constraints.------   (2) The choice increases the set of active constraints. For the new---       active constraints, we must check that they are consistent with---       the current state.------ We can actually merge (1) and (2) by saying the current choice is--- a new active constraint, fixing the choice.------ If a test fails, we have detected an inconsistent state. We can--- disable the current subtree and do not have to traverse it any further.------ We need a good way to represent the current state, i.e., the current--- set of active constraints. Since the main situation where we have to--- search in it is (1), it seems best to store the state by package: for--- every package, we store which versions are still allowed. If for any--- package, we have inconsistent active constraints, we can also stop.--- This is a particular way to read task (2):------   (2, weak) We only check if the new constraints are consistent with---       the choices we've already made, and add them to the active set.------   (2, strong) We check if the new constraints are consistent with the---       choices we've already made, and the constraints we already have.------ It currently seems as if we're implementing the weak variant. However,--- when used together with 'preferEasyGoalChoices', we will find an--- inconsistent state in the very next step.------ What do we do about flags?------ Like for packages, we store the flag choices we have already made.--- Now, regarding (1), we only have to test whether we've decided the--- current flag before. Regarding (2), the interesting bit is in discovering--- the new active constraints. To this end, we look up the constraints for--- the package the flag belongs to, and traverse its flagged dependencies.--- Wherever we find the flag in question, we start recording dependencies--- underneath as new active dependencies. If we encounter other flags, we--- check if we've chosen them already and either proceed or stop.---- | The state needed during validation.-data ValidateState = VS {-  supportedExt        :: Extension -> Bool,-  supportedLang       :: Language  -> Bool,-  presentPkgs         :: PkgconfigName -> PkgconfigVersionRange  -> Bool,-  index               :: Index,--  -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,-  -- it qualifies the package's dependencies and saves them in this map. Then-  -- the qualified dependencies are available for subsequent flag and stanza-  -- choices for the same package.-  saved               :: Map QPN (FlaggedDeps QPN),--  pa                  :: PreAssignment,--  -- Map from package name to the components that are provided by the chosen-  -- instance of that package, and whether those components are visible and-  -- buildable.-  availableComponents :: Map QPN (Map ExposedComponent ComponentInfo),--  -- Map from package name to the components that are required from that-  -- package.-  requiredComponents  :: Map QPN ComponentDependencyReasons,--  qualifyOptions      :: QualifyOptions-}--newtype Validate a = Validate (Reader ValidateState a)-  deriving (Functor, Applicative, Monad, MonadReader ValidateState)--runValidate :: Validate a -> ValidateState -> a-runValidate (Validate r) = runReader r---- | A preassignment comprises knowledge about variables, but not--- necessarily fixed values.-data PreAssignment = PA PPreAssignment FAssignment SAssignment---- | A (partial) package preassignment. Qualified package names--- are associated with MergedPkgDeps.-type PPreAssignment = Map QPN MergedPkgDep---- | A dependency on a component, including its DependencyReason.-data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI---- | Map from component name to one of the reasons that the component is--- required.-type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)---- | MergedPkgDep records constraints about the instances that can still be--- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a--- list of version ranges paired with the goals / variables that introduced--- them. It also records whether a package is a build-tool dependency, for each--- reason that it was introduced.------ It is important to store the component name with the version constraint, for--- error messages, because whether something is a build-tool dependency affects--- its qualifier, which affects which constraint is applied.-data MergedPkgDep =-    MergedDepFixed ExposedComponent (DependencyReason QPN) I-  | MergedDepConstrained [VROrigin]---- | Version ranges paired with origins.-type VROrigin = (VR, ExposedComponent, DependencyReason QPN)---- | The information needed to create a 'Fail' node.-type Conflict = (ConflictSet, FailReason)--validate :: Tree d c -> Validate (Tree d c)-validate = cata go-  where-    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)--    go (PChoiceF qpn rdm gr       ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts)-    go (FChoiceF qfn rdm gr b m d ts) =-      do-        -- Flag choices may occur repeatedly (because they can introduce new constraints-        -- in various places). However, subsequent choices must be consistent. We thereby-        -- collapse repeated flag choice nodes.-        PA _ pfa _ <- asks pa -- obtain current flag-preassignment-        case M.lookup qfn pfa of-          Just rb -> -- flag has already been assigned; collapse choice to the correct branch-                     case W.lookup rb ts of-                       Just t  -> goF qfn rb t-                       Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)-          Nothing -> -- flag choice is new, follow both branches-                     FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts)-    go (SChoiceF qsn rdm gr b   ts) =-      do-        -- Optional stanza choices are very similar to flag choices.-        PA _ _ psa <- asks pa -- obtain current stanza-preassignment-        case M.lookup qsn psa of-          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch-                     case W.lookup rb ts of-                       Just t  -> goS qsn rb t-                       Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)-          Nothing -> -- stanza choice is new, follow both branches-                     SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts)--    -- We don't need to do anything for goal choices or failure nodes.-    go (GoalChoiceF rdm           ts) = GoalChoice rdm <$> sequence ts-    go (DoneF       rdm s           ) = pure (Done rdm s)-    go (FailF    c fr               ) = pure (Fail c fr)--    -- What to do for package nodes ...-    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)-    goP qpn@(Q _pp pn) (POption i _) r = do-      PA ppa pfa psa <- asks pa    -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      idx            <- asks index -- obtain the index-      svd            <- asks saved -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      qo             <- asks qualifyOptions-      -- obtain dependencies and index-dictated exclusions introduced by the choice-      let (PInfo deps comps _ mfr) = idx ! pn ! i-      -- qualify the deps in the current scope-      let qdeps = qualifyDeps qo qpn deps-      -- the new active constraints are given by the instance we have chosen,-      -- plus the dependency information we have for that instance-      let newactives = extractAllDeps pfa psa qdeps-      -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend extSupported langSupported pkgPresent newactives-                   =<< extendWithPackageChoice (PI qpn i) ppa-      -- In case we continue, we save the scoped dependencies-      let nsvd = M.insert qpn qdeps svd-      case mfr of-        Just fr -> -- The index marks this as an invalid choice. We can stop.-                   return (Fail (varToConflictSet (P qpn)) fr)-        Nothing ->-          let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)-              newDeps = do-                nppa <- mnppa-                rComps' <- extendRequiredComponents qpn aComps rComps newactives-                checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps-                return (nppa, rComps')-          in case newDeps of-               Left (c, fr)          -> -- We have an inconsistency. We can stop.-                                        return (Fail c fr)-               Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation.-                                        local (\ s -> s { pa = PA nppa pfa psa-                                                        , saved = nsvd-                                                        , availableComponents = M.insert qpn comps aComps-                                                        , requiredComponents = rComps'-                                                        }) r--    -- What to do for flag nodes ...-    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goF qfn@(FN qpn _f) b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs-      svd            <- asks saved         -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npfa = M.insert qfn b pfa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (F qfn) b npfa psa qdeps-          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives-      -- As in the package case, we try to extend the partial assignment.-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa-      case liftM2 (,) mnppa mNewRequiredComps of-        Left (c, fr)         -> return (Fail c fr) -- inconsistency found-        Right (nppa, rComps') ->-            local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r--    -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goS qsn@(SN qpn _f) b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      svd            <- asks saved         -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npsa = M.insert qsn b psa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (S qsn) b pfa npsa qdeps-          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives-      -- As in the package case, we try to extend the partial assignment.-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa-      case liftM2 (,) mnppa mNewRequiredComps of-        Left (c, fr)         -> return (Fail c fr) -- inconsistency found-        Right (nppa, rComps') ->-            local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r---- | Check that a newly chosen package instance contains all components that--- are required from that package so far. The components must also be visible--- and buildable.-checkComponentsInNewPackage :: ComponentDependencyReasons-                            -> QPN-                            -> Map ExposedComponent ComponentInfo-                            -> Either Conflict ()-checkComponentsInNewPackage required qpn providedComps =-    case M.toList $ deleteKeys (M.keys providedComps) required of-      (missingComp, dr) : _ ->-          Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent-      []                    ->-          let failures = lefts-                  [ case () of-                      _ | compIsVisible compInfo == IsVisible False ->-                          Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent-                        | compIsBuildable compInfo == IsBuildable False ->-                          Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent-                        | otherwise -> Right ()-                  | let merged = M.intersectionWith (,) required providedComps-                  , (comp, (dr, compInfo)) <- M.toList merged ]-          in case failures of-               failure : _ -> Left failure-               []          -> Right ()-  where-    mkConflict :: ExposedComponent-               -> DependencyReason QPN-               -> (ExposedComponent -> DependencyReason QPN -> FailReason)-               -> Conflict-    mkConflict comp dr mkFailure =-        (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr)--    deleteKeys :: Ord k => [k] -> Map k v -> Map k v-    deleteKeys ks m = L.foldr M.delete m ks---- | We try to extract as many concrete dependencies from the given flagged--- dependencies as possible. We make use of all the flag knowledge we have--- already acquired.-extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]-extractAllDeps fa sa deps = do-  d <- deps-  case d of-    Simple sd _         -> return sd-    Flagged qfn _ td fd -> case M.lookup qfn fa of-                             Nothing    -> mzero-                             Just True  -> extractAllDeps fa sa td-                             Just False -> extractAllDeps fa sa fd-    Stanza qsn td       -> case M.lookup qsn sa of-                             Nothing    -> mzero-                             Just True  -> extractAllDeps fa sa td-                             Just False -> []---- | We try to find new dependencies that become available due to the given--- flag or stanza choice. We therefore look for the choice in question, and then call--- 'extractAllDeps' for everything underneath.-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]-extractNewDeps v b fa sa = go-  where-    go :: FlaggedDeps QPN -> [LDep QPN]-    go deps = do-      d <- deps-      case d of-        Simple _ _           -> mzero-        Flagged qfn' _ td fd-          | v == F qfn'      -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd-          | otherwise        -> case M.lookup qfn' fa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> go fd-        Stanza qsn' td-          | v == S qsn'      -> if b then extractAllDeps fa sa td else []-          | otherwise        -> case M.lookup qsn' sa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> []---- | Extend a package preassignment.------ Takes the variable that causes the new constraints, a current preassignment--- and a set of new dependency constraints.------ We're trying to extend the preassignment with each dependency one by one.--- Each dependency is for a particular variable. We check if we already have--- constraints for that variable in the current preassignment. If so, we're--- trying to merge the constraints.------ Either returns a witness of the conflict that would arise during the merge,--- or the successfully extended assignment.-extend :: (Extension -> Bool)            -- ^ is a given extension supported-       -> (Language  -> Bool)            -- ^ is a given language supported-       -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable-       -> [LDep QPN]-       -> PPreAssignment-       -> Either Conflict PPreAssignment-extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives-  where--    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment-    extendSingle a (LDep dr (Ext  ext ))  =-      if extSupported  ext  then Right a-                            else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext)-    extendSingle a (LDep dr (Lang lang))  =-      if langSupported lang then Right a-                            else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang)-    extendSingle a (LDep dr (Pkg pn vr))  =-      if pkgPresent pn vr then Right a-                          else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr)-    extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) =-      let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a-      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of-            Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')-            Right x           -> Right x---- | Extend a package preassignment with a package choice. For example, when--- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.------ TODO: The new constraint is implemented as a dependency from foo to foo's--- main library. That isn't correct, because foo might only be needed as a build--- tool dependency. The implemention may need to change when we support--- component-based dependency solving.-extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment-extendWithPackageChoice (PI qpn i) ppa =-  let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa-      newChoice = PkgDep (DependencyReason qpn M.empty S.empty)-                         (PkgComponent qpn (ExposedLib LMainLibName))-                         (Fixed i)-  in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of-        Left (c, (d, _d')) -> -- Don't include the package choice in the-                              -- FailReason, because it is redundant.-                              Left (c, NewPackageDoesNotMatchExistingConstraint d)-        Right x            -> Right x---- | Merge constrained instances. We currently adopt a lazy strategy for--- merging, i.e., we only perform actual checking if one of the two choices--- is fixed. If the merge fails, we return a conflict set indicating the--- variables responsible for the failure, as well as the two conflicting--- fragments.------ Note that while there may be more than one conflicting pair of version--- ranges, we only return the first we find.------ The ConflictingDeps are returned in order, i.e., the first describes the--- conflicting part of the MergedPkgDep, and the second describes the PkgDep.------ TODO: Different pairs might have different conflict sets. We're--- obviously interested to return a conflict that has a "better" conflict--- set in the sense the it contains variables that allow us to backjump--- further. We might apply some heuristics here, such as to change the--- order in which we check the constraints.-merge ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep-merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))-  | i1 == i2  = Right $ MergedDepFixed comp1 vs1 i1-  | otherwise =-      Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2-           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)-             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))-  | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i-  | otherwise    =-      Left ( createConflictSetForVersionConflict p v vs1 vr vs2-           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)-             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =-    go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...-  where-    go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep-    go [] = Right (MergedDepFixed comp2 vs2 i)-    go ((vr, comp1, vs1) : vros)-       | checkVR vr v = go vros-       | otherwise    =-           Left ( createConflictSetForVersionConflict p v vs2 vr vs1-                , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr)-                  , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) =-    Right (MergedDepConstrained $--    -- TODO: This line appends the new version range, to preserve the order used-    -- before a refactoring. Consider prepending the version range, if there is-    -- no negative performance impact.-    vrOrigins ++ [(vr, comp2, vs2)])---- | Creates a conflict set representing a conflict between a version constraint--- and the fixed version chosen for a package.-createConflictSetForVersionConflict :: QPN-                                    -> Ver-                                    -> DependencyReason QPN-                                    -> VR-                                    -> DependencyReason QPN-                                    -> ConflictSet-createConflictSetForVersionConflict pkg-                                    conflictingVersion-                                    versionDR@(DependencyReason p1 _ _)-                                    conflictingVersionRange-                                    versionRangeDR@(DependencyReason p2 _ _) =-  let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss)-  in-    -- The solver currently only optimizes the case where there is a conflict-    -- between the version chosen for a package and a version constraint that-    -- is not under any flags or stanzas. Here is how we check for this case:-    ---    --   (1) Choosing a specific version for a package foo is implemented as-    --       adding a dependency from foo to that version of foo (See-    --       extendWithPackageChoice), so we check that the DependencyReason-    --       contains the current package and no flag or stanza choices.-    ---    --   (2) We check that the DependencyReason for the version constraint also-    --       contains no flag or stanza choices.-    ---    -- When these criteria are not met, we fall back to calling-    -- dependencyReasonToConflictSet.-    if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR)-    then let cs1 = dependencyReasonToConflictSetWithVersionConflict-                   p2-                   (CS.OrderedVersionRange conflictingVersionRange)-                   versionDR-             cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict-                   pkg conflictingVersion versionRangeDR-         in cs1 `CS.union` cs2-    else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR---- | Takes a list of new dependencies and uses it to try to update the map of--- known component dependencies. It returns a failure when a new dependency--- requires a component that is missing, private, or unbuildable in a previously--- chosen package.-extendRequiredComponents :: QPN -- ^ package we extend-                         -> Map QPN (Map ExposedComponent ComponentInfo)-                         -> Map QPN ComponentDependencyReasons-                         -> [LDep QPN]-                         -> Either Conflict (Map QPN ComponentDependencyReasons)-extendRequiredComponents eqpn available = foldM extendSingle-  where-    extendSingle :: Map QPN ComponentDependencyReasons-                 -> LDep QPN-                 -> Either Conflict (Map QPN ComponentDependencyReasons)-    extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) =-      let compDeps = M.findWithDefault M.empty qpn required-          success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required-      in -- Only check for the existence of the component if its package has-         -- already been chosen.-         case M.lookup qpn available of-           Just comps ->-               case M.lookup comp comps of-                 Nothing ->-                     Left $ mkConflict qpn comp dr PackageRequiresMissingComponent-                 Just compInfo-                   | compIsVisible compInfo == IsVisible False-                   , eqpn /= qpn -- package components can depend on other components-                   ->-                     Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent-                   | compIsBuildable compInfo == IsBuildable False ->-                     Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent-                   | otherwise -> success-           Nothing    -> success-    extendSingle required _                                         = Right required--    mkConflict :: QPN-               -> ExposedComponent-               -> DependencyReason QPN-               -> (QPN -> ExposedComponent -> FailReason)-               -> Conflict-    mkConflict qpn comp dr mkFailure =-      (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp)----- | Interface.-validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c-validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {-    supportedExt        = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported-                                (\ es -> let s = S.fromList es in \ x -> S.member x s)-                                (compilerInfoExtensions cinfo)-  , supportedLang       = maybe (const True)-                                (flip L.elem) -- use list lookup because language list is small and no Ord instance-                                (compilerInfoLanguages  cinfo)-  , presentPkgs         = pkgConfigPkgIsPresent pkgConfigDb-  , index               = idx-  , saved               = M.empty-  , pa                  = PA M.empty M.empty M.empty-  , availableComponents = M.empty-  , requiredComponents  = M.empty-  , qualifyOptions      = defaultQualifyOptions idx-  }
− cabal-install-solver/src/Distribution/Solver/Modular/Var.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Var (-    Var(..)-  , showVar-  , varPN-  ) where--import Prelude hiding (pi)--import Distribution.Solver.Modular.Flag-import Distribution.Solver.Types.PackagePath--{--------------------------------------------------------------------------------  Variables--------------------------------------------------------------------------------}---- | The type of variables that play a role in the solver.--- Note that the tree currently does not use this type directly,--- and rather has separate tree nodes for the different types of--- variables. This fits better with the fact that in most cases,--- these have to be treated differently.-data Var qpn = P qpn | F (FN qpn) | S (SN qpn)-  deriving (Eq, Ord, Show, Functor)--showVar :: Var QPN -> String-showVar (P qpn) = showQPN qpn-showVar (F qfn) = showQFN qfn-showVar (S qsn) = showQSN qsn---- | Extract the package name from a Var-varPN :: Var qpn -> qpn-varPN (P qpn)        = qpn-varPN (F (FN qpn _)) = qpn-varPN (S (SN qpn _)) = qpn
− cabal-install-solver/src/Distribution/Solver/Modular/Version.hs 
@@ -1,56 +0,0 @@-module Distribution.Solver.Modular.Version-    ( Ver-    , VR-    , anyVR-    , checkVR-    , eqVR-    , showVer-    , showVR-    , simplifyVR-    , (.&&.)-    , (.||.)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Distribution.Version as CV -- from Cabal-import Distribution.Pretty (prettyShow)---- | Preliminary type for versions.-type Ver = CV.Version---- | String representation of a version.-showVer :: Ver -> String-showVer = prettyShow---- | Version range. Consists of a lower and upper bound.-type VR = CV.VersionRange---- | String representation of a version range.-showVR :: VR -> String-showVR = prettyShow---- | Unconstrained version range.-anyVR :: VR-anyVR = CV.anyVersion---- | Version range fixing a single version.-eqVR :: Ver -> VR-eqVR = CV.thisVersion---- | Intersect two version ranges.-(.&&.) :: VR -> VR -> VR-v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2---- | Union of two version ranges.-(.||.) :: VR -> VR -> VR-v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2---- | Simplify a version range.-simplifyVR :: VR -> VR-simplifyVR = CV.simplifyVersionRange---- | Checking a version against a version range.-checkVR :: VR -> Ver -> Bool-checkVR = flip CV.withinRange
− cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.WeightedPSQ (-    WeightedPSQ-  , fromList-  , toList-  , keys-  , weights-  , isZeroOrOne-  , filter-  , lookup-  , mapWithKey-  , mapWeightsWithKey-  , union-  , takeUntil-  ) where--import qualified Data.Foldable as F-import qualified Data.List as L-import Data.Ord (comparing)-import qualified Data.Traversable as T-import Prelude hiding (filter, lookup)---- | An association list that is sorted by weight.------ Each element has a key ('k'), value ('v'), and weight ('w'). All operations--- that add elements or modify weights stably sort the elements by weight.-newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)]-  deriving (Eq, Show, Functor, F.Foldable, T.Traversable)---- | /O(N)/.-filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v-filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs)---- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements.-isZeroOrOne :: WeightedPSQ w k v -> Bool-isZeroOrOne (WeightedPSQ [])  = True-isZeroOrOne (WeightedPSQ [_]) = True-isZeroOrOne _                 = False---- | /O(1)/. Return the elements in order.-toList :: WeightedPSQ w k v -> [(w, k, v)]-toList (WeightedPSQ xs) = xs---- | /O(N log N)/.-fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v-fromList = WeightedPSQ . L.sortBy (comparing triple_1)---- | /O(N)/. Return the weights in order.-weights :: WeightedPSQ w k v -> [w]-weights (WeightedPSQ xs) = L.map triple_1 xs---- | /O(N)/. Return the keys in order.-keys :: WeightedPSQ w k v -> [k]-keys (WeightedPSQ xs) = L.map triple_2 xs---- | /O(N)/. Return the value associated with the first occurrence of the give--- key, if it exists.-lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v-lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs---- | /O(N log N)/. Update the weights.-mapWeightsWithKey :: Ord w2-                  => (k -> w1 -> w2)-                  -> WeightedPSQ w1 k v-                  -> WeightedPSQ w2 k v-mapWeightsWithKey f (WeightedPSQ xs) = fromList $-                                       L.map (\ (w, k, v) -> (f k w, k, v)) xs---- | /O(N)/. Update the values.-mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2-mapWithKey f (WeightedPSQ xs) = WeightedPSQ $-                                L.map (\ (w, k, v) -> (w, k, f k v)) xs---- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all--- elements. Elements from the first @WeightedPSQ@ come before elements in the--- second when they have the same weight.-union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v-union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys)---- | /O(N)/. Return the prefix of values ending with the first element that--- satisfies p, or all elements if none satisfy p.-takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v-takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs)-  where-    go :: [(w, k, v)] -> [(w, k, v)]-    go []       = []-    go (y : ys) = y : if p (triple_3 y) then [] else go ys--triple_1 :: (x, y, z) -> x-triple_1 (x, _, _) = x--triple_2 :: (x, y, z) -> y-triple_2 (_, y, _) = y--triple_3 :: (x, y, z) -> z-triple_3 (_, _, z) = z
− cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}---- | Fine-grained package dependencies------ Like many others, this module is meant to be "double-imported":------ > import Distribution.Solver.Types.ComponentDeps (--- >     Component--- >   , ComponentDep--- >   , ComponentDeps--- >   )--- > import qualified Distribution.Solver.Types.ComponentDeps as CD-module Distribution.Solver.Types.ComponentDeps (-    -- * Fine-grained package dependencies-    Component(..)-  , componentNameToComponent-  , ComponentDep-  , ComponentDeps -- opaque-    -- ** Constructing ComponentDeps-  , empty-  , fromList-  , singleton-  , insert-  , zip-  , filterDeps-  , fromLibraryDeps-  , fromSetupDeps-  , fromInstalled-    -- ** Deconstructing ComponentDeps-  , toList-  , flatDeps-  , nonSetupDeps-  , libraryDeps-  , setupDeps-  , select-  , components-  ) where--import Prelude ()-import Distribution.Types.UnqualComponentName-import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)--import qualified Data.Map as Map-import Data.Foldable (fold)--import Distribution.Pretty (Pretty (..))-import qualified Distribution.Types.ComponentName as CN-import qualified Distribution.Types.LibraryName as LN-import qualified Text.PrettyPrint as PP---{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}---- | Component of a package.-data Component =-    ComponentLib-  | ComponentSubLib UnqualComponentName-  | ComponentFLib   UnqualComponentName-  | ComponentExe    UnqualComponentName-  | ComponentTest   UnqualComponentName-  | ComponentBench  UnqualComponentName-  | ComponentSetup-  deriving (Show, Eq, Ord, Generic)--instance Binary Component-instance Structured Component--instance Pretty Component where-    pretty ComponentLib        = PP.text "lib"-    pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n-    pretty (ComponentFLib n)   = PP.text "flib:" <<>> pretty n-    pretty (ComponentExe n)    = PP.text "exe:" <<>> pretty n-    pretty (ComponentTest n)   = PP.text "test:" <<>> pretty n-    pretty (ComponentBench n)  = PP.text "bench:" <<>> pretty n-    pretty ComponentSetup      = PP.text "setup"---- | Dependency for a single component.-type ComponentDep a = (Component, a)---- | Fine-grained dependencies for a package.------ Typically used as @ComponentDeps [Dependency]@, to represent the list of--- dependencies for each named component within a package.----newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }-  deriving (Show, Functor, Eq, Ord, Generic)--instance Semigroup a => Monoid (ComponentDeps a) where-  mempty = ComponentDeps Map.empty-  mappend = (<>)--instance Semigroup a => Semigroup (ComponentDeps a) where-  ComponentDeps d <> ComponentDeps d' =-      ComponentDeps (Map.unionWith (<>) d d')--instance Foldable ComponentDeps where-  foldMap f = foldMap f . unComponentDeps--instance Traversable ComponentDeps where-  traverse f = fmap ComponentDeps . traverse f . unComponentDeps--instance Binary a => Binary (ComponentDeps a)-instance Structured a => Structured (ComponentDeps a)--componentNameToComponent :: CN.ComponentName -> Component-componentNameToComponent (CN.CLibName  LN.LMainLibName)   = ComponentLib-componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s-componentNameToComponent (CN.CFLibName                s)  = ComponentFLib   s-componentNameToComponent (CN.CExeName                 s)  = ComponentExe    s-componentNameToComponent (CN.CTestName                s)  = ComponentTest   s-componentNameToComponent (CN.CBenchName               s)  = ComponentBench  s--{--------------------------------------------------------------------------------  Construction--------------------------------------------------------------------------------}--empty :: ComponentDeps a-empty = ComponentDeps $ Map.empty--fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a-fromList = ComponentDeps . Map.fromListWith mappend--singleton :: Component -> a -> ComponentDeps a-singleton comp = ComponentDeps . Map.singleton comp--insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a-insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps-  where-    aux Nothing   = Just a-    aux (Just a') = Just $ a `mappend` a'---- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'--- as the neutral element when a 'Component' is present only in one.-zip-  :: (Monoid a, Monoid b)-  => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)-zip (ComponentDeps d1) (ComponentDeps d2) =-    ComponentDeps $-      Map.mergeWithKey-        (\_ a b -> Just (a,b))-        (fmap (\a -> (a, mempty)))-        (fmap (\b -> (mempty, b)))-        d1 d2---- | Keep only selected components (and their associated deps info).-filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a-filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps---- | ComponentDeps containing library dependencies only-fromLibraryDeps :: a -> ComponentDeps a-fromLibraryDeps = singleton ComponentLib---- | ComponentDeps containing setup dependencies only.-fromSetupDeps :: a -> ComponentDeps a-fromSetupDeps = singleton ComponentSetup---- | ComponentDeps for installed packages.------ We assume that installed packages only record their library dependencies.-fromInstalled :: a -> ComponentDeps a-fromInstalled = fromLibraryDeps--{--------------------------------------------------------------------------------  Deconstruction--------------------------------------------------------------------------------}--toList :: ComponentDeps a -> [ComponentDep a]-toList = Map.toList . unComponentDeps---- | All dependencies of a package.------ This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more--- obvious than a use of 'fold', and moreover this avoids introducing lots of--- @#ifdef@s for 7.10 just for the use of 'fold'.-flatDeps :: Monoid a => ComponentDeps a -> a-flatDeps = fold---- | All dependencies except the setup dependencies.------ Prior to the introduction of setup dependencies in version 1.24 this--- would have been _all_ dependencies.-nonSetupDeps :: Monoid a => ComponentDeps a -> a-nonSetupDeps = select (/= ComponentSetup)---- | Library dependencies proper only.  (Includes dependencies--- of internal libraries.)-libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (\c -> case c of ComponentSubLib _ -> True-                                      ComponentLib -> True-                                      _ -> False)---- | List components-components :: ComponentDeps a -> Set Component-components = Map.keysSet . unComponentDeps---- | Setup dependencies.-setupDeps :: Monoid a => ComponentDeps a -> a-setupDeps = select (== ComponentSetup)---- | Select dependencies satisfying a given predicate.-select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a-select p = foldMap snd . filter (p . fst) . toList
− cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.ConstraintSource-    ( ConstraintSource(..)-    , showConstraintSource-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()---- | Source of a 'PackageConstraint'.-data ConstraintSource =--  -- | Main config file, which is ~/.cabal/config by default.-  ConstraintSourceMainConfig FilePath--  -- | Local cabal.project file-  | ConstraintSourceProjectConfig FilePath--  -- | Sandbox config file, which is ./cabal.sandbox.config by default.-  | ConstraintSourceSandboxConfig FilePath--  -- | User config file, which is ./cabal.config by default.-  | ConstraintSourceUserConfig FilePath--  -- | Flag specified on the command line.-  | ConstraintSourceCommandlineFlag--  -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@-  -- implies @package==0.1.0.0@.-  | ConstraintSourceUserTarget--  -- | Internal requirement to use installed versions of packages like ghc-prim.-  | ConstraintSourceNonUpgradeablePackage--  -- | Internal requirement to use the add-source version of a package when that-  -- version is installed and the source is modified.-  | ConstraintSourceModifiedAddSourceDep--  -- | Internal constraint used by @cabal freeze@.-  | ConstraintSourceFreeze--  -- | Constraint specified by a config file, a command line flag, or a user-  -- target, when a more specific source is not known.-  | ConstraintSourceConfigFlagOrTarget--  -- | The source of the constraint is not specified.-  | ConstraintSourceUnknown--  -- | An internal constraint due to compatibility issues with the Setup.hs-  -- command line interface requires a minimum lower bound on Cabal-  | ConstraintSetupCabalMinVersion--  -- | An internal constraint due to compatibility issues with the Setup.hs-  -- command line interface requires a maximum upper bound on Cabal-  | ConstraintSetupCabalMaxVersion-  deriving (Eq, Show, Generic)--instance Binary ConstraintSource-instance Structured ConstraintSource---- | Description of a 'ConstraintSource'.-showConstraintSource :: ConstraintSource -> String-showConstraintSource (ConstraintSourceMainConfig path) =-    "main config " ++ path-showConstraintSource (ConstraintSourceProjectConfig path) =-    "project config " ++ path-showConstraintSource (ConstraintSourceSandboxConfig path) =-    "sandbox config " ++ path-showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path-showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"-showConstraintSource ConstraintSourceUserTarget = "user target"-showConstraintSource ConstraintSourceNonUpgradeablePackage =-    "non-upgradeable package"-showConstraintSource ConstraintSourceModifiedAddSourceDep =-    "modified add-source dependency"-showConstraintSource ConstraintSourceFreeze = "cabal freeze"-showConstraintSource ConstraintSourceConfigFlagOrTarget =-    "config file, command line flag, or user target"-showConstraintSource ConstraintSourceUnknown = "unknown source"-showConstraintSource ConstraintSetupCabalMinVersion =-    "minimum version of Cabal used by Setup.hs"-showConstraintSource ConstraintSetupCabalMaxVersion =-    "maximum version of Cabal used by Setup.hs"
− cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs 
@@ -1,37 +0,0 @@-module Distribution.Solver.Types.DependencyResolver-    ( DependencyResolver-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PackageIndex ( PackageIndex )-import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.ResolverPackage-import Distribution.Solver.Types.SourcePackage--import Distribution.Simple.PackageIndex ( InstalledPackageIndex )-import Distribution.Package ( PackageName )-import Distribution.Compiler ( CompilerInfo )-import Distribution.System ( Platform )---- | A dependency resolver is a function that works out an installation plan--- given the set of installed and available packages and a set of deps to--- solve for.------ The reason for this interface is because there are dozens of approaches to--- solving the package dependency problem and we want to make it easy to swap--- in alternatives.----type DependencyResolver loc = Platform-                           -> CompilerInfo-                           -> InstalledPackageIndex-                           -> PackageIndex (SourcePackage loc)-                           -> PkgConfigDb-                           -> (PackageName -> PackagePreferences)-                           -> [LabeledPackageConstraint]-                           -> Set PackageName-                           -> Progress String String [ResolverPackage loc]
− cabal-install-solver/src/Distribution/Solver/Types/Flag.hs 
@@ -1,8 +0,0 @@-module Distribution.Solver.Types.Flag-    ( FlagType(..)-    ) where--import Prelude (Eq, Show)--data FlagType = Manual | Automatic-  deriving (Eq, Show)
− cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.InstSolverPackage-    ( InstSolverPackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )-import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import Distribution.Solver.Types.SolverId-import Distribution.Types.MungedPackageId-import Distribution.Types.PackageId-import Distribution.Types.MungedPackageName-import Distribution.InstalledPackageInfo (InstalledPackageInfo)---- | An 'InstSolverPackage' is a pre-existing installed package--- specified by the dependency solver.-data InstSolverPackage = InstSolverPackage {-      instSolverPkgIPI :: InstalledPackageInfo,-      instSolverPkgLibDeps :: ComponentDeps [SolverId],-      instSolverPkgExeDeps :: ComponentDeps [SolverId]-    }-  deriving (Eq, Show, Generic)--instance Binary InstSolverPackage-instance Structured InstSolverPackage--instance Package InstSolverPackage where-    packageId i =-        -- HACK! See Note [Index conversion with internal libraries]-        let MungedPackageId mpn v = mungedId i-        in PackageIdentifier (encodeCompatPackageName mpn) v--instance HasMungedPackageId InstSolverPackage where-    mungedId = mungedId . instSolverPkgIPI--instance HasUnitId InstSolverPackage where-    installedUnitId = installedUnitId . instSolverPkgIPI
− cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs 
@@ -1,11 +0,0 @@-module Distribution.Solver.Types.InstalledPreference-    ( InstalledPreference(..),-    ) where--import Prelude (Show)---- | Whether we prefer an installed version of a package or simply the latest--- version.----data InstalledPreference = PreferInstalled | PreferLatest-  deriving Show
− cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs 
@@ -1,14 +0,0 @@-module Distribution.Solver.Types.LabeledPackageConstraint-    ( LabeledPackageConstraint(..)-    , unlabelPackageConstraint-    ) where--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.PackageConstraint---- | 'PackageConstraint' labeled with its source.-data LabeledPackageConstraint-   = LabeledPackageConstraint PackageConstraint ConstraintSource--unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint-unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
− cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Solver.Types.OptionalStanza (-    -- * OptionalStanza-    OptionalStanza(..),-    showStanza,-    showStanzas,-    enableStanzas,-    -- * Set of stanzas-    OptionalStanzaSet,-    optStanzaSetFromList,-    optStanzaSetToList,-    optStanzaSetMember,-    optStanzaSetInsert,-    optStanzaSetSingleton,-    optStanzaSetIntersection,-    optStanzaSetNull,-    optStanzaSetIsSubset,-    -- * Map indexed by stanzas-    OptionalStanzaMap,-    optStanzaTabulate,-    optStanzaIndex,-    optStanzaLookup,-    optStanzaKeysFilteredByValue,-) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Data.Bits                                 (testBit, (.|.), (.&.))-import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..))-import Distribution.Utils.Structured (Structured (..), nominalStructure)------------------------------------------------------------------------------------ OptionalStanza----------------------------------------------------------------------------------data OptionalStanza-    = TestStanzas-    | BenchStanzas-  deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable)---- | String representation of an OptionalStanza.-showStanza :: OptionalStanza -> String-showStanza TestStanzas  = "test"-showStanza BenchStanzas = "bench"--showStanzas :: OptionalStanzaSet -> String-showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList---- | Convert a list of 'OptionalStanza' into the corresponding--- Cabal's 'ComponentRequestedSpec' which records what components are enabled.----enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec-enableStanzas optionalStanzas = ComponentRequestedSpec-    { testsRequested      = optStanzaSetMember TestStanzas  optionalStanzas-    , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas-    }--instance Binary OptionalStanza-instance Structured OptionalStanza------------------------------------------------------------------------------------ OptionalStanzaSet----------------------------------------------------------------------------------newtype OptionalStanzaSet = OptionalStanzaSet Word-  deriving (Eq, Ord, Show)--instance Binary OptionalStanzaSet where-    put (OptionalStanzaSet w) = put w-    get = fmap (OptionalStanzaSet . (.&. 0x03)) get--instance Structured OptionalStanzaSet where-    structure = nominalStructure--optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet-optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty--optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza]-optStanzaSetToList (OptionalStanzaSet 0) = []-optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas]-optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas]-optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas]-optStanzaSetToList (OptionalStanzaSet _) = []--optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet-optStanzaSetInsert x s = optStanzaSetSingleton x <> s--optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool-optStanzaSetMember TestStanzas  (OptionalStanzaSet w) = testBit w 0-optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1--optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet-optStanzaSetSingleton TestStanzas  = OptionalStanzaSet 1-optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2--optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet-optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b)--optStanzaSetNull :: OptionalStanzaSet -> Bool-optStanzaSetNull (OptionalStanzaSet w) = w == 0--optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool-optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b--instance Semigroup OptionalStanzaSet where-    OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b)--instance Monoid OptionalStanzaSet where-    mempty = OptionalStanzaSet 0-    mappend = (<>)------------------------------------------------------------------------------------ OptionalStanzaMap------------------------------------------------------------------------------------ | Note: this is total map.-data OptionalStanzaMap a = OptionalStanzaMap a a-  deriving (Eq, Ord, Show, Generic)--instance Binary a => Binary (OptionalStanzaMap a)-instance Structured a => Structured (OptionalStanzaMap a)--optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a-optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas)--optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a-optStanzaIndex (OptionalStanzaMap x _) TestStanzas  = x-optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x--optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a-optStanzaLookup = flip optStanzaIndex--optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet-optStanzaKeysFilteredByValue p (OptionalStanzaMap x y)-    | p x       = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1-    | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0
− cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---- | Per-package constraints. Package constraints must be respected by the--- solver. Multiple constraints for each package can be given, though obviously--- it is possible to construct conflicting constraints (eg impossible version--- range or inconsistent flag assignment).----module Distribution.Solver.Types.PackageConstraint (-    ConstraintScope(..),-    scopeToplevel,-    scopeToPackageName,-    constraintScopeMatches,-    PackageProperty(..),-    dispPackageProperty,-    PackageConstraint(..),-    dispPackageConstraint,-    showPackageConstraint,-    packageConstraintToDependency-  ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package                        (PackageName)-import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)-import Distribution.Pretty                         (flatStyle, pretty)-import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))-import Distribution.Version                        (VersionRange, simplifyVersionRange)--import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath--import qualified Text.PrettyPrint as Disp----- | Determines to what packages and in what contexts a--- constraint applies.-data ConstraintScope-     -- | A scope that applies when the given package is used as a build target.-     -- In other words, the scope applies iff a goal has a top-level qualifier-     -- and its namespace matches the given package name. A namespace is-     -- considered to match a package name when it is either the default-     -- namespace (for --no-independent-goals) or it is an independent namespace-     -- with the given package name (for --independent-goals).--     -- TODO: Try to generalize the ConstraintScopes once component-based-     -- solving is implemented, and remove this special case for targets.-   = ScopeTarget PackageName-     -- | The package with the specified name and qualifier.-   | ScopeQualified Qualifier PackageName-     -- | The package with the specified name when it has a-     -- setup qualifier.-   | ScopeAnySetupQualifier PackageName-     -- | The package with the specified name regardless of-     -- qualifier.-   | ScopeAnyQualifier PackageName-  deriving (Eq, Show)---- | Constructor for a common use case: the constraint applies to--- the package with the specified name when that package is a--- top-level dependency in the default namespace.-scopeToplevel :: PackageName -> ConstraintScope-scopeToplevel = ScopeQualified QualToplevel---- | Returns the package name associated with a constraint scope.-scopeToPackageName :: ConstraintScope -> PackageName-scopeToPackageName (ScopeTarget pn) = pn-scopeToPackageName (ScopeQualified _ pn) = pn-scopeToPackageName (ScopeAnySetupQualifier pn) = pn-scopeToPackageName (ScopeAnyQualifier pn) = pn--constraintScopeMatches :: ConstraintScope -> QPN -> Bool-constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =-  let namespaceMatches DefaultNamespace = True-      namespaceMatches (Independent namespacePn) = pn == namespacePn-  in namespaceMatches ns && q == QualToplevel && pn == pn'-constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =-    q == q' && pn == pn'-constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =-  let setup (PackagePath _ (QualSetup _)) = True-      setup _                             = False-  in setup pp && pn == pn'-constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'---- | Pretty-prints a constraint scope.-dispConstraintScope :: ConstraintScope -> Disp.Doc-dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn-dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn-dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn-dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn---- | A package property is a logical predicate on packages.-data PackageProperty-   = PackagePropertyVersion   VersionRange-   | PackagePropertyInstalled-   | PackagePropertySource-   | PackagePropertyFlags     FlagAssignment-   | PackagePropertyStanzas   [OptionalStanza]-  deriving (Eq, Show, Generic)--instance Binary PackageProperty-instance Structured PackageProperty---- | Pretty-prints a package property.-dispPackageProperty :: PackageProperty -> Disp.Doc-dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange-dispPackageProperty PackagePropertyInstalled          = Disp.text "installed"-dispPackageProperty PackagePropertySource             = Disp.text "source"-dispPackageProperty (PackagePropertyFlags flags)      = dispFlagAssignment flags-dispPackageProperty (PackagePropertyStanzas stanzas)  =-  Disp.hsep $ map (Disp.text . showStanza) stanzas---- | A package constraint consists of a scope plus a property--- that must hold for all packages within that scope.-data PackageConstraint = PackageConstraint ConstraintScope PackageProperty-  deriving (Eq, Show)---- | Pretty-prints a package constraint.-dispPackageConstraint :: PackageConstraint -> Disp.Doc-dispPackageConstraint (PackageConstraint scope prop) =-  dispConstraintScope scope <+> dispPackageProperty prop---- | Alternative textual representation of a package constraint--- for debugging purposes (slightly more verbose than that--- produced by 'dispPackageConstraint').----showPackageConstraint :: PackageConstraint -> String-showPackageConstraint pc@(PackageConstraint scope prop) =-  Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2-  where-    pc2 = case prop of-      PackagePropertyVersion vr ->-        PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr)-      _ -> pc-    postprocess = case prop of-      PackagePropertyFlags _ -> (Disp.text "flags" <+>)-      PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>)-      _ -> id---- | Lossily convert a 'PackageConstraint' to a 'Dependency'.-packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint-packageConstraintToDependency (PackageConstraint scope prop) = toDep prop-  where-    toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr-    toDep (PackagePropertyInstalled)  = Nothing-    toDep (PackagePropertySource)     = Nothing-    toDep (PackagePropertyFlags _)    = Nothing-    toDep (PackagePropertyStanzas _)  = Nothing
− cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs 
@@ -1,23 +0,0 @@-module Distribution.Solver.Types.PackageFixedDeps-    ( PackageFixedDeps(..)-    ) where--import           Distribution.InstalledPackageInfo ( InstalledPackageInfo )-import           Distribution.Package-                   ( Package(..), UnitId, installedDepends)-import           Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import qualified Distribution.Solver.Types.ComponentDeps as CD---- | Subclass of packages that have specific versioned dependencies.------ So for example a not-yet-configured package has dependencies on version--- ranges, not specific versions. A configured or an already installed package--- depends on exact versions. Some operations or data structures (like---  dependency graphs) only make sense on this subclass of package types.----class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> ComponentDeps [UnitId]--instance PackageFixedDeps InstalledPackageInfo where-  depends pkg = CD.fromInstalled (installedDepends pkg)-
− cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Solver.Types.PackageIndex--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ An index of packages.----module Distribution.Solver.Types.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,-  override,-  insert,-  deletePackageName,-  deletePackageId,-  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  elemByPackageId,-  elemByPackageName,-  lookupPackageName,-  lookupPackageId,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,-  searchWithPredicate,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (lookup)--import qualified Data.Map as Map-import Data.List (isInfixOf)-import qualified Data.List.NonEmpty as NE--import Distribution.Client.Utils.Assertion ( expensiveAssert )-import Distribution.Package-         ( PackageName, unPackageName, PackageIdentifier(..)-         , Package(..), packageName, packageVersion )-import Distribution.Version-         ( VersionRange, withinRange )-import Distribution.Simple.Utils-         ( lowercase )--import qualified Prelude (foldr1)---- | The collection of information about packages from one or more 'PackageDB's.------ It can be searched efficiently by package name and version.----newtype PackageIndex pkg = PackageIndex-  -- This index package names to all the package records matching that package-  -- name case-sensitively. It includes all versions.-  ---  -- This allows us to find all versions satisfying a dependency.-  -- Most queries are a map lookup followed by a linear scan of the bucket.-  ---  (Map PackageName [pkg])--  deriving (Eq, Show, Read, Functor, Generic)---FIXME: the Functor instance here relies on no package id changes--instance Package pkg => Semigroup (PackageIndex pkg) where-  (<>) = merge--instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex Map.empty-  mappend = (<>)-  --save one mappend with empty in the common case:-  mconcat [] = mempty-  mconcat xs = Prelude.foldr1 mappend xs--instance Binary pkg => Binary (PackageIndex pkg)--invariant :: Package pkg => PackageIndex pkg -> Bool-invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)-  where-    goodBucket _    [] = False-    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0-      where-        check pkgid []          = packageName pkgid == name-        check pkgid (pkg':pkgs) = packageName pkgid == name-                               && pkgid < pkgid'-                               && check pkgid' pkgs-          where pkgid' = packageId pkg'------- * Internal helpers-----mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg-mkPackageIndex index = expensiveAssert (invariant (PackageIndex index))-                                         (PackageIndex index)--internalError :: String -> a-internalError name = error ("PackageIndex." ++ name ++ ": internal error")---- | Lookup a name in the index to get all packages that match that name--- case-sensitively.----lookup :: PackageIndex pkg -> PackageName -> [pkg]-lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m------- * Construction------- | Build an index out of a bunch of packages.------ If there are duplicates, later ones mask earlier ones.----fromList :: Package pkg => [pkg] -> PackageIndex pkg-fromList pkgs = mkPackageIndex-              . Map.map fixBucket-              . Map.fromListWith (++)-              $ [ (packageName pkg, [pkg])-                | pkg <- pkgs ]-  where-    fixBucket = -- out of groups of duplicates, later ones mask earlier ones-                -- but Map.fromListWith (++) constructs groups in reverse order-                map NE.head-                -- Eq instance for PackageIdentifier is wrong, so use Ord:-              . NE.groupBy (\a b -> EQ == comparing packageId a b)-                -- relies on sortBy being a stable sort so we-                -- can pick consistently among duplicates-              . sortBy (comparing packageId)------- * Updates------- | Merge two indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-merge i1@(PackageIndex m1) i2@(PackageIndex m2) =-  expensiveAssert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)----- | Elements in the second list mask those in the first.-mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]-mergeBuckets []     ys     = ys-mergeBuckets xs     []     = xs-mergeBuckets xs@(x:xs') ys@(y:ys') =-      case packageId x `compare` packageId y of-        GT -> y : mergeBuckets xs  ys'-        EQ -> y : mergeBuckets xs' ys'-        LT -> x : mergeBuckets xs' ys---- | Override-merge oftwo indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-override i1@(PackageIndex m1) i2@(PackageIndex m2) =-  expensiveAssert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2)---- | Inserts a single package into the index.------ This is equivalent to (but slightly quicker than) using 'mappend' or--- 'merge' with a singleton index.----insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg-insert pkg (PackageIndex index) = mkPackageIndex $-  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index-  where-    pkgid = packageId pkg-    insertNoDup []                = [pkg]-    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of-      LT -> pkg  : pkgs-      EQ -> pkg  : pkgs'-      GT -> pkg' : insertNoDup pkgs'---- | Internal delete helper.----delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg-       -> PackageIndex pkg-delete name p (PackageIndex index) = mkPackageIndex $-  Map.update filterBucket name index-  where-    filterBucket = deleteEmptyBucket-                 . filter (not . p)-    deleteEmptyBucket []        = Nothing-    deleteEmptyBucket remaining = Just remaining---- | Removes a single package from the index.----deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg-                -> PackageIndex pkg-deletePackageId pkgid =-  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)---- | Removes all packages with this (case-sensitive) name from the index.----deletePackageName :: Package pkg => PackageName -> PackageIndex pkg-                  -> PackageIndex pkg-deletePackageName name =-  delete name (\pkg -> packageName pkg == name)---- | Removes all packages satisfying this dependency from the index.-deleteDependency :: Package pkg-                 => PackageName -> VersionRange -> PackageIndex pkg-                 -> PackageIndex pkg-deleteDependency name verstionRange =-  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)------- * Bulk queries------- | Get all the packages from the index.----allPackages :: PackageIndex pkg -> [pkg]-allPackages (PackageIndex m) = concat (Map.elems m)---- | Get all the packages from the index.------ They are grouped by package name, case-sensitively.----allPackagesByName :: PackageIndex pkg -> [[pkg]]-allPackagesByName (PackageIndex m) = Map.elems m------- * Lookups-----elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool-elemByPackageId index = isJust . lookupPackageId index--elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool-elemByPackageName index = not . null . lookupPackageName index----- | Does a lookup by package id (name & version).------ Since multiple package DBs mask each other case-sensitively by package name,--- then we get back at most one package.----lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier-                -> Maybe pkg-lookupPackageId index pkgid =-  case [ pkg | pkg <- lookup index (packageName pkgid)-             , packageId pkg == pkgid ] of-    []    -> Nothing-    [pkg] -> Just pkg-    _     -> internalError "lookupPackageIdentifier"---- | Does a case-sensitive search by package name.----lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]-lookupPackageName index name =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name ]---- | Does a case-sensitive search by package name and a range of versions.------ We get back any number of versions of the specified package name, all--- satisfying the version range constraint.----lookupDependency :: Package pkg-                 => PackageIndex pkg-                 -> PackageName -> VersionRange-                 -> [pkg]-lookupDependency index name versionRange =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name-        , packageVersion pkg `withinRange` versionRange ]------- * Case insensitive name lookups------- | Does a case-insensitive search by package name.------ If there is only one package that compares case-insensitively to this name--- then the search is unambiguous and we get back all versions of that package.--- If several match case-insensitively but one matches exactly then it is also--- unambiguous.------ If however several match case-insensitively and none match exactly then we--- have an ambiguous result, and we get back all the versions of all the--- packages. The list of ambiguous results is split by exact package name. So--- it is a non-empty list of non-empty lists.----searchByName :: PackageIndex pkg-             -> String -> [(PackageName, [pkg])]-searchByName (PackageIndex m) name =-    [ pkgs-    | pkgs@(pname,_) <- Map.toList m-    , lowercase (unPackageName pname) == lname ]-  where-    lname = lowercase name--data SearchResult a = None | Unambiguous a | Ambiguous [a]---- | Does a case-insensitive substring search by package name.------ That is, all packages that contain the given string in their name.----searchByNameSubstring :: PackageIndex pkg-                      -> String -> [(PackageName, [pkg])]-searchByNameSubstring index searchterm =-    searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)-  where lsearchterm = lowercase searchterm--searchWithPredicate :: PackageIndex pkg-                    -> (String -> Bool) -> [(PackageName, [pkg])]-searchWithPredicate (PackageIndex m) predicate =-    [ pkgs-    | pkgs@(pname, _) <- Map.toList m-    , predicate (unPackageName pname)-    ]
− cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs 
@@ -1,102 +0,0 @@-module Distribution.Solver.Types.PackagePath-    ( PackagePath(..)-    , Namespace(..)-    , Qualifier(..)-    , dispQualifier-    , Qualified(..)-    , QPN-    , dispQPN-    , showQPN-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()-import Distribution.Package (PackageName)-import Distribution.Pretty (pretty, flatStyle)-import qualified Text.PrettyPrint as Disp---- | A package path consists of a namespace and a package path inside that--- namespace.-data PackagePath = PackagePath Namespace Qualifier-  deriving (Eq, Ord, Show)---- | Top-level namespace------ Package choices in different namespaces are considered completely independent--- by the solver.-data Namespace =-    -- | The default namespace-    DefaultNamespace--    -- | A namespace for a specific build target-  | Independent PackageName-  deriving (Eq, Ord, Show)---- | Pretty-prints a namespace. The result is either empty or--- ends in a period, so it can be prepended onto a qualifier.-dispNamespace :: Namespace -> Disp.Doc-dispNamespace DefaultNamespace = Disp.empty-dispNamespace (Independent i) = pretty i <<>> Disp.text "."---- | Qualifier of a package within a namespace (see 'PackagePath')-data Qualifier =-    -- | Top-level dependency in this namespace-    QualToplevel--    -- | Any dependency on base is considered independent-    ---    -- This makes it possible to have base shims.-  | QualBase PackageName--    -- | Setup dependency-    ---    -- By rights setup dependencies ought to be nestable; after all, the setup-    -- dependencies of a package might themselves have setup dependencies, which-    -- are independent from everything else. However, this very quickly leads to-    -- infinite search trees in the solver. Therefore we limit ourselves to-    -- a single qualifier (within a given namespace).-  | QualSetup PackageName--    -- | If we depend on an executable from a package (via-    -- @build-tools@), we should solve for the dependencies of that-    -- package separately (since we're not going to actually try to-    -- link it.)  We qualify for EACH package separately; e.g.,-    -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on-    -- @pn2@ from package @pn1@.  (If we tracked only @pn1@, that-    -- would require a consistent dependency resolution for all-    -- of the depended upon executables from a package; if we-    -- tracked only @pn2@, that would require us to pick only one-    -- version of an executable over the entire install plan.)-  | QualExe PackageName PackageName-  deriving (Eq, Ord, Show)---- | Pretty-prints a qualifier. The result is either empty or--- ends in a period, so it can be prepended onto a package name.------ NOTE: the base qualifier is for a dependency _on_ base; the qualifier is--- there to make sure different dependencies on base are all independent.--- So we want to print something like @"A.base"@, where the @"A."@ part--- is the qualifier and @"base"@ is the actual dependency (which, for the--- 'Base' qualifier, will always be @base@).-dispQualifier :: Qualifier -> Disp.Doc-dispQualifier QualToplevel = Disp.empty-dispQualifier (QualSetup pn)  = pretty pn <<>> Disp.text ":setup."-dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>-                                 pretty pn2 <<>> Disp.text ":exe."-dispQualifier (QualBase pn)  = pretty pn <<>> Disp.text "."---- | A qualified entity. Pairs a package path with the entity.-data Qualified a = Q PackagePath a-  deriving (Eq, Ord, Show)---- | Qualified package name.-type QPN = Qualified PackageName---- | Pretty-prints a qualified package name.-dispQPN :: QPN -> Disp.Doc-dispQPN (Q (PackagePath ns qual) pn) =-  dispNamespace ns <<>> dispQualifier qual <<>> pretty pn---- | String representation of a qualified package name.-showQPN :: QPN -> String-showQPN = Disp.renderStyle flatStyle . dispQPN
− cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs 
@@ -1,22 +0,0 @@-module Distribution.Solver.Types.PackagePreferences-    ( PackagePreferences(..)-    ) where--import Distribution.Solver.Types.InstalledPreference-import Distribution.Solver.Types.OptionalStanza-import Distribution.Version (VersionRange)---- | Per-package preferences on the version. It is a soft constraint that the--- 'DependencyResolver' should try to respect where possible. It consists of--- an 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also has (possibly multiple)--- 'PackageVersionPreference's which are suggested constraints on the version--- number. The resolver should try to use package versions that satisfy--- the maximum number of the suggested version constraints.------ It is not specified if preferences on some packages are more important than--- others.----data PackagePreferences = PackagePreferences [VersionRange]-                                             InstalledPreference-                                             [OptionalStanza]
− cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Solver.Types.PkgConfigDb--- Copyright   :  (c) Iñaki García Etxebarria 2016--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Read the list of packages available to pkg-config.-------------------------------------------------------------------------------module Distribution.Solver.Types.PkgConfigDb-    ( PkgConfigDb-    , readPkgConfigDb-    , pkgConfigDbFromList-    , pkgConfigPkgIsPresent-    , pkgConfigDbPkgVersion-    , getPkgConfigDbDirs-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import           Control.Exception (handle)-import qualified Data.Map          as M-import           System.FilePath   (splitSearchPath)--import Distribution.Compat.Environment          (lookupEnv)-import Distribution.Package                     (PkgconfigName, mkPkgconfigName)-import Distribution.Parsec-import Distribution.Simple.Program-       (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram)-import Distribution.Simple.Utils                (info)-import Distribution.Types.PkgconfigVersion-import Distribution.Types.PkgconfigVersionRange-import Distribution.Verbosity                   (Verbosity)---- | The list of packages installed in the system visible to--- @pkg-config@. This is an opaque datatype, to be constructed with--- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.-data PkgConfigDb =  PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion))-                 -- ^ If an entry is `Nothing`, this means that the-                 -- package seems to be present, but we don't know the-                 -- exact version (because parsing of the version-                 -- number failed).-                 | NoPkgConfigDb-                 -- ^ For when we could not run pkg-config successfully.-     deriving (Show, Generic, Typeable)--instance Binary PkgConfigDb-instance Structured PkgConfigDb---- | Query pkg-config for the list of installed packages, together--- with their versions. Return a `PkgConfigDb` encapsulating this--- information.-readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb-readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do-    mpkgConfig <- needProgram verbosity pkgConfigProgram progdb-    case mpkgConfig of-      Nothing             -> noPkgConfig "Cannot find pkg-config program"-      Just (pkgConfig, _) -> do-        pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]-        -- The output of @pkg-config --list-all@ also includes a description-        -- for each package, which we do not need.-        let pkgNames = map (takeWhile (not . isSpace)) pkgList-        pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig-                                   ("--modversion" : pkgNames)-        (return . pkgConfigDbFromList . zip pkgNames) pkgVersions-  where-    -- For when pkg-config invocation fails (possibly because of a-    -- too long command line).-    noPkgConfig extra = do-        info verbosity ("Failed to query pkg-config, Cabal will continue"-                        ++ " without solving for pkg-config constraints: "-                        ++ extra)-        return NoPkgConfigDb--    ioErrorHandler :: IOException -> IO PkgConfigDb-    ioErrorHandler e = noPkgConfig (show e)---- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.-pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb-pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs-    where-      convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion)-      convert (n,vs) = (mkPkgconfigName n, simpleParsec vs)---- | Check whether a given package range is satisfiable in the given--- @pkg-config@ database.-pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool-pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =-    case M.lookup pn db of-      Nothing       -> False    -- Package not present in the DB.-      Just Nothing  -> True     -- Package present, but version unknown.-      Just (Just v) -> withinPkgconfigVersionRange v vr--- If we could not read the pkg-config database successfully we allow--- the check to succeed. The plan found by the solver may fail to be--- executed later on, but we have no grounds for rejecting the plan at--- this stage.-pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True----- | Query the version of a package in the @pkg-config@ database.--- @Nothing@ indicates the package is not in the database, while--- @Just Nothing@ indicates that the package is in the database,--- but its version is not known.-pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion)-pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db--- NB: Since the solver allows solving to succeed if there is--- NoPkgConfigDb, we should report that we *guess* that there--- is a matching pkg-config configuration, but that we just--- don't know about it.-pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing----- | Query pkg-config for the locations of pkg-config's package files. Use this--- to monitor for changes in the pkg-config DB.----getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath]-getPkgConfigDbDirs verbosity progdb =-    (++) <$> getEnvPath <*> getDefPath- where-    -- According to @man pkg-config@:-    ---    -- PKG_CONFIG_PATH-    -- A  colon-separated  (on Windows, semicolon-separated) list of directories-    -- to search for .pc files.  The default directory will always be searched-    -- after searching the path-    ---    getEnvPath = maybe [] parseSearchPath-             <$> lookupEnv "PKG_CONFIG_PATH"--    -- Again according to @man pkg-config@:-    ---    -- pkg-config can be used to query itself for the default search path,-    -- version number and other information, for instance using:-    ---    -- > pkg-config --variable pc_path pkg-config-    ---    getDefPath = handle ioErrorHandler $ do-      mpkgConfig <- needProgram verbosity pkgConfigProgram progdb-      case mpkgConfig of-        Nothing -> return []-        Just (pkgConfig, _) -> parseSearchPath <$>-          getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"]--    parseSearchPath str =-      case lines str of-        [p] | not (null p) -> splitSearchPath p-        _                  -> []--    ioErrorHandler :: IOException -> IO [FilePath]-    ioErrorHandler _e = return []
− cabal-install-solver/src/Distribution/Solver/Types/Progress.hs 
@@ -1,49 +0,0 @@-module Distribution.Solver.Types.Progress-    ( Progress(..)-    , foldProgress-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (fail)---- | A type to represent the unfolding of an expensive long running--- calculation that may fail. We may get intermediate steps before the final--- result which may be used to indicate progress and\/or logging messages.----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done---- This Functor instance works around a bug in GHC 7.6.3.--- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637.--- The derived functor instance caused a space leak in the solver.-instance Functor (Progress step fail) where-  fmap f (Step s p) = Step s (fmap f p)-  fmap _ (Fail x)   = Fail x-  fmap f (Done r)   = Done (f r)---- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two--- base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r--instance Monad (Progress step fail) where-  return   = pure-  p >>= f  = foldProgress Step Fail f p--instance Applicative (Progress step fail) where-  pure a  = Done a-  p <*> x = foldProgress Step Fail (flip fmap x) p--instance Monoid fail => Alternative (Progress step fail) where-  empty   = Fail mempty-  p <|> q = foldProgress Step (const q) Done p
− cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.ResolverPackage-    ( ResolverPackage(..)-    , resolverPackageLibDeps-    , resolverPackageExeDeps-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Types.InstSolverPackage-import Distribution.Solver.Types.SolverId-import Distribution.Solver.Types.SolverPackage-import qualified Distribution.Solver.Types.ComponentDeps as CD--import Distribution.Compat.Graph (IsNode(..))-import Distribution.Package (Package(..), HasUnitId(..))-import Distribution.Simple.Utils (ordNub)---- | The dependency resolver picks either pre-existing installed packages--- or it picks source packages along with package configuration.------ This is like the 'InstallPlan.PlanPackage' but with fewer cases.----data ResolverPackage loc = PreExisting InstSolverPackage-                         | Configured  (SolverPackage loc)-  deriving (Eq, Show, Generic)--instance Binary loc => Binary (ResolverPackage loc)-instance Structured loc => Structured (ResolverPackage loc)--instance Package (ResolverPackage loc) where-  packageId (PreExisting ipkg)     = packageId ipkg-  packageId (Configured  spkg)     = packageId spkg--resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]-resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg-resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg--resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]-resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg-resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg--instance IsNode (ResolverPackage loc) where-  type Key (ResolverPackage loc) = SolverId-  nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg)-  nodeKey (Configured spkg) = PlannedId (packageId spkg)-  -- Use dependencies for ALL components-  nodeNeighbors pkg =-    ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++-             CD.flatDeps (resolverPackageExeDeps pkg)
− cabal-install-solver/src/Distribution/Solver/Types/Settings.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Solver.Types.Settings-    ( ReorderGoals(..)-    , IndependentGoals(..)-    , MinimizeConflictSet(..)-    , AvoidReinstalls(..)-    , ShadowPkgs(..)-    , StrongFlags(..)-    , AllowBootLibInstalls(..)-    , OnlyConstrained(..)-    , EnableBackjumping(..)-    , CountConflicts(..)-    , FineGrainedConflicts(..)-    , SolveExecutables(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Simple.Setup ( BooleanFlag(..) )-import Distribution.Pretty ( Pretty(pretty) )-import Distribution.Parsec ( Parsec(parsec) )--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as PP--newtype ReorderGoals = ReorderGoals Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype CountConflicts = CountConflicts Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype FineGrainedConflicts = FineGrainedConflicts Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype MinimizeConflictSet = MinimizeConflictSet Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype IndependentGoals = IndependentGoals Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype AvoidReinstalls = AvoidReinstalls Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype ShadowPkgs = ShadowPkgs Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype StrongFlags = StrongFlags Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype AllowBootLibInstalls = AllowBootLibInstalls Bool-  deriving (BooleanFlag, Eq, Generic, Show)---- | Should we consider all packages we know about, or only those that--- have constraints explicitly placed on them or which are goals?-data OnlyConstrained-  = OnlyConstrainedNone-  | OnlyConstrainedAll-  deriving (Eq, Generic, Show)--newtype EnableBackjumping = EnableBackjumping Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype SolveExecutables = SolveExecutables Bool-  deriving (BooleanFlag, Eq, Generic, Show)--instance Binary ReorderGoals-instance Binary CountConflicts-instance Binary FineGrainedConflicts-instance Binary IndependentGoals-instance Binary MinimizeConflictSet-instance Binary AvoidReinstalls-instance Binary ShadowPkgs-instance Binary StrongFlags-instance Binary AllowBootLibInstalls-instance Binary OnlyConstrained-instance Binary SolveExecutables--instance Structured ReorderGoals-instance Structured CountConflicts-instance Structured FineGrainedConflicts-instance Structured IndependentGoals-instance Structured MinimizeConflictSet-instance Structured AvoidReinstalls-instance Structured ShadowPkgs-instance Structured StrongFlags-instance Structured AllowBootLibInstalls-instance Structured OnlyConstrained-instance Structured SolveExecutables--instance Pretty OnlyConstrained where-  pretty OnlyConstrainedAll  = PP.text "all"-  pretty OnlyConstrainedNone = PP.text "none"--instance Parsec OnlyConstrained where-  parsec = P.choice-    [ P.string "all"  >> return OnlyConstrainedAll-    , P.string "none" >> return OnlyConstrainedNone-    ]-
− cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.SolverId-    ( SolverId(..)-    )--where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package (PackageId, Package(..), UnitId)---- | The solver can produce references to existing packages or--- packages we plan to install.  Unlike 'ConfiguredId' we don't--- yet know the 'UnitId' for planned packages, because it's--- not the solver's job to compute them.----data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }-              | PlannedId     { solverSrcId :: PackageId }-  deriving (Eq, Ord, Generic)--instance Binary SolverId-instance Structured SolverId--instance Show SolverId where-    show = show . solverSrcId--instance Package SolverId where-  packageId = solverSrcId
− cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.SolverPackage-    ( SolverPackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package ( Package(..) )-import Distribution.PackageDescription ( FlagAssignment )-import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.SolverId-import Distribution.Solver.Types.SourcePackage---- | A 'SolverPackage' is a package specified by the dependency solver.--- It will get elaborated into a 'ConfiguredPackage' or even an--- 'ElaboratedConfiguredPackage'.------ NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc',--- but for symmetry we have the parameter.  (Maybe it can be removed.)----data SolverPackage loc = SolverPackage {-        solverPkgSource  :: SourcePackage loc,-        solverPkgFlags   :: FlagAssignment,-        solverPkgStanzas :: OptionalStanzaSet,-        solverPkgLibDeps :: ComponentDeps [SolverId],-        solverPkgExeDeps :: ComponentDeps [SolverId]-    }-  deriving (Eq, Show, Generic)--instance Binary loc => Binary (SolverPackage loc)-instance Structured loc => Structured (SolverPackage loc)--instance Package (SolverPackage loc) where-  packageId = packageId . solverPkgSource
− cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Distribution.Solver.Types.SourcePackage-    ( PackageDescriptionOverride-    , SourcePackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package-         ( PackageId, Package(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(..) )--import Data.ByteString.Lazy (ByteString)---- | A package description along with the location of the package sources.----data SourcePackage loc = SourcePackage-  { srcpkgPackageId     :: PackageId-  , srcpkgDescription   :: GenericPackageDescription-    -- ^ Note, this field is lazy, e.g. when reading in hackage index-    --   we parse only what we need, not whole index.-  , srcpkgSource        :: loc-  , srcpkgDescrOverride :: PackageDescriptionOverride-  }-  deriving (Eq, Show, Generic, Typeable)--instance Binary loc => Binary (SourcePackage loc)-instance Structured loc => Structured (SourcePackage loc)--instance Package (SourcePackage a) where packageId = srcpkgPackageId---- | We sometimes need to override the .cabal file in the tarball with--- the newer one from the package index.-type PackageDescriptionOverride = Maybe ByteString
− cabal-install-solver/src/Distribution/Solver/Types/Variable.hs 
@@ -1,15 +0,0 @@-module Distribution.Solver.Types.Variable where--import Prelude (Eq, Show)--import Distribution.Solver.Types.OptionalStanza--import Distribution.PackageDescription (FlagName)---- | Variables used by the dependency solver. This type is similar to the--- internal 'Var' type.-data Variable qpn =-    PackageVar qpn-  | FlagVar qpn FlagName-  | StanzaVar qpn OptionalStanza-  deriving (Eq, Show)
cabal-install.cabal view
@@ -1,10 +1,7 @@-Cabal-Version:      >= 1.10--- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'.--- DO NOT EDIT MANUALLY.--- To update this file, edit 'cabal-install.cabal.pp' and run--- 'make cabal-install-prod' in the project's root folder.+Cabal-Version:      2.2+ Name:               cabal-install-Version:            3.6.2.0+Version:            3.8.1.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -12,15 +9,17 @@     and installation of Haskell libraries and programs. homepage:           http://www.haskell.org/cabal/ bug-reports:        https://github.com/haskell/cabal/issues-License:            BSD3+License:            BSD-3-Clause License-File:       LICENSE Author:             Cabal Development Team (see AUTHORS file) Maintainer:         Cabal Development Team <cabal-devel@haskell.org>-Copyright:          2003-2020, Cabal Development Team+Copyright:          2003-2022, Cabal Development Team Category:           Distribution Build-type:         Simple Extra-Source-Files:-  README.md bash-completion/cabal changelog+  README.md+  bash-completion/cabal+  changelog  source-repository head   type:     git@@ -28,52 +27,42 @@   subdir:   cabal-install  Flag native-dns-  description:  Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups+  description:+    Enable use of the [resolv](https://hackage.haskell.org/package/resolv)+    & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups   default:      True   manual:       True -Flag debug-expensive-assertions-  description:  Enable expensive assertions for testing or debugging-  default:      False-  manual:       True--Flag debug-conflict-sets-  description:  Add additional information to ConflictSets-  default:      False-  manual:       True--Flag debug-tracetree-  description:  Compile in support for tracetree (used to debug the solver)-  default:      False-  manual:       True- Flag lukko   description:  Use @lukko@ for file-locking   default:      True   manual:       True -executable cabal-    main-is:        Main.hs-    hs-source-dirs: main-    default-language: Haskell2010-    ghc-options:    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates-    if impl(ghc >= 8.0)-        ghc-options: -Wcompat-                     -Wnoncanonical-monad-instances-      if impl(ghc < 8.8)-        ghc-options: -Wnoncanonical-monadfail-instances+common warnings+    ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates+    if impl(ghc < 8.8)+      ghc-options: -Wnoncanonical-monadfail-instances+    if impl(ghc >=8.10)+      ghc-options: -Wunused-packages -      if impl(ghc >=8.10)-        ghc-options: -Wunused-packages+common base-dep+    build-depends: base >=4.10 && <4.17 +common cabal-dep+    build-depends: Cabal ^>=3.8 -    ghc-options: -rtsopts -threaded+common cabal-syntax-dep+    build-depends: Cabal-syntax ^>=3.8 -    -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a-    if os(aix)-        extra-libraries: bsd-    hs-source-dirs: src-    other-modules:+common cabal-install-solver-dep+    build-depends: cabal-install-solver ^>=3.8++library+    import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+    default-language: Haskell2010++    hs-source-dirs:   src+    exposed-modules:         -- this modules are moved from Cabal         -- they are needed for as long until cabal-install moves to parsec parser         Distribution.Deprecated.ParseUtils@@ -99,6 +88,7 @@         Distribution.Client.CmdInstall.ClientInstallTargetSelector         Distribution.Client.CmdLegacy         Distribution.Client.CmdListBin+        Distribution.Client.CmdOutdated         Distribution.Client.CmdRepl         Distribution.Client.CmdRun         Distribution.Client.CmdSdist@@ -106,7 +96,6 @@         Distribution.Client.CmdUpdate         Distribution.Client.Compat.Directory         Distribution.Client.Compat.ExecutablePath-        Distribution.Client.Compat.FilePerms         Distribution.Client.Compat.Orphans         Distribution.Client.Compat.Prelude         Distribution.Client.Compat.Process@@ -133,12 +122,16 @@         Distribution.Client.IndexUtils.IndexState         Distribution.Client.IndexUtils.Timestamp         Distribution.Client.Init-        Distribution.Client.Init.Command         Distribution.Client.Init.Defaults         Distribution.Client.Init.FileCreators-        Distribution.Client.Init.Heuristics+        Distribution.Client.Init.FlagExtractors+        Distribution.Client.Init.Format+        Distribution.Client.Init.Interactive.Command+        Distribution.Client.Init.NonInteractive.Command+        Distribution.Client.Init.NonInteractive.Heuristics         Distribution.Client.Init.Licenses         Distribution.Client.Init.Prompt+        Distribution.Client.Init.Simple         Distribution.Client.Init.Types         Distribution.Client.Init.Utils         Distribution.Client.Install@@ -150,7 +143,6 @@         Distribution.Client.ManpageFlags         Distribution.Client.Nix         Distribution.Client.NixStyleOptions-        Distribution.Client.Outdated         Distribution.Client.PackageHash         Distribution.Client.ParseUtils         Distribution.Client.ProjectBuilding@@ -169,6 +161,7 @@         Distribution.Client.Sandbox         Distribution.Client.Sandbox.PackageEnvironment         Distribution.Client.SavedFlags+        Distribution.Client.ScriptUtils         Distribution.Client.Security.DNS         Distribution.Client.Security.HTTP         Distribution.Client.Setup@@ -202,84 +195,24 @@         Distribution.Client.Utils.Json         Distribution.Client.Utils.Parsec         Distribution.Client.VCS+        Distribution.Client.Version         Distribution.Client.Win32SelfUpgrade-        Distribution.Client.World -    hs-source-dirs: cabal-install-solver/src-assertion-    other-modules:-        Distribution.Client.Utils.Assertion--    hs-source-dirs: cabal-install-solver/src-    other-modules:-        Distribution.Solver.Compat.Prelude-        Distribution.Solver.Modular-        Distribution.Solver.Modular.Assignment-        Distribution.Solver.Modular.Builder-        Distribution.Solver.Modular.Configured-        Distribution.Solver.Modular.ConfiguredConversion-        Distribution.Solver.Modular.ConflictSet-        Distribution.Solver.Modular.Cycles-        Distribution.Solver.Modular.Dependency-        Distribution.Solver.Modular.Explore-        Distribution.Solver.Modular.Flag-        Distribution.Solver.Modular.Index-        Distribution.Solver.Modular.IndexConversion-        Distribution.Solver.Modular.LabeledGraph-        Distribution.Solver.Modular.Linking-        Distribution.Solver.Modular.Log-        Distribution.Solver.Modular.Message-        Distribution.Solver.Modular.PSQ-        Distribution.Solver.Modular.Package-        Distribution.Solver.Modular.Preference-        Distribution.Solver.Modular.RetryLog-        Distribution.Solver.Modular.Solver-        Distribution.Solver.Modular.Tree-        Distribution.Solver.Modular.Validate-        Distribution.Solver.Modular.Var-        Distribution.Solver.Modular.Version-        Distribution.Solver.Modular.WeightedPSQ-        Distribution.Solver.Types.ComponentDeps-        Distribution.Solver.Types.ConstraintSource-        Distribution.Solver.Types.DependencyResolver-        Distribution.Solver.Types.Flag-        Distribution.Solver.Types.InstSolverPackage-        Distribution.Solver.Types.InstalledPreference-        Distribution.Solver.Types.LabeledPackageConstraint-        Distribution.Solver.Types.OptionalStanza-        Distribution.Solver.Types.PackageConstraint-        Distribution.Solver.Types.PackageFixedDeps-        Distribution.Solver.Types.PackageIndex-        Distribution.Solver.Types.PackagePath-        Distribution.Solver.Types.PackagePreferences-        Distribution.Solver.Types.PkgConfigDb-        Distribution.Solver.Types.Progress-        Distribution.Solver.Types.ResolverPackage-        Distribution.Solver.Types.Settings-        Distribution.Solver.Types.SolverId-        Distribution.Solver.Types.SolverPackage-        Distribution.Solver.Types.SourcePackage-        Distribution.Solver.Types.Variable--    other-modules:-        Paths_cabal_install-     build-depends:         async      >= 2.0      && < 2.3,         array      >= 0.4      && < 0.6,-        base       >= 4.8      && < 4.15,         base16-bytestring >= 0.1.1 && < 1.1.0.0,         binary     >= 0.7.3    && < 0.9,         bytestring >= 0.10.6.0 && < 0.12,-        Cabal      == 3.6.*,         containers >= 0.5.6.2  && < 0.7,         cryptohash-sha256 >= 0.11 && < 0.12,-        deepseq    >= 1.4.1.1  && < 1.5,         directory  >= 1.2.2.0  && < 1.4,         echo       >= 0.1.3    && < 0.2,         edit-distance >= 0.2.2 && < 0.3,+        exceptions >= 0.10.4   && < 0.11,         filepath   >= 1.4.0.0  && < 1.5,-        hashable   >= 1.0      && < 1.4,-        HTTP       >= 4000.1.5 && < 4000.4,+        hashable   >= 1.0      && < 1.5,+        HTTP       >= 4000.1.5 && < 4000.5,         mtl        >= 2.0      && < 2.3,         network-uri >= 2.6.0.2 && < 2.7,         pretty     >= 1.1      && < 1.2,@@ -287,18 +220,14 @@         random     >= 1.2      && < 1.3,         stm        >= 2.0      && < 2.6,         tar        >= 0.5.0.3  && < 0.6,-        time       >= 1.5.0.1  && < 1.11,-        transformers >= 0.4.2.0 && < 0.6,+        time       >= 1.5.0.1  && < 1.12,         zlib       >= 0.5.3    && < 0.7,-        hackage-security >= 0.6.0.1 && < 0.7,+        hackage-security >= 0.6.2.0 && < 0.7,         text       >= 1.2.3    && < 1.3,         parsec     >= 3.1.13.0 && < 3.2,         regex-base  >= 0.94.0.0 && <0.95,-        regex-posix >= 0.96.0.0 && <0.97--    if !impl(ghc >= 8.0)-        build-depends: fail        == 4.9.*-        build-depends: semigroups  >= 0.18.3 && <0.20+        regex-posix >= 0.96.0.0 && <0.97,+        safe-exceptions >= 0.1.7.0 && < 0.2      if flag(native-dns)       if os(windows)@@ -308,22 +237,181 @@      if os(windows)       -- newer directory for symlinks-      build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0+      build-depends: Win32 >= 2.8 && < 3, directory >=1.3.1.0     else       build-depends: unix >= 2.5 && < 2.9      if flag(lukko)       build-depends: lukko >= 0.1 && <0.2-    else-      build-depends: base >= 4.10 -    if flag(debug-expensive-assertions)-      cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS -    if flag(debug-conflict-sets)-      cpp-options: -DDEBUG_CONFLICT_SETS-      build-depends: base >= 4.8+executable cabal+    import: warnings, base-dep, cabal-dep, cabal-syntax-dep+    main-is: Main.hs+    hs-source-dirs: main+    default-language: Haskell2010 -    if flag(debug-tracetree)-      cpp-options: -DDEBUG_TRACETREE-      build-depends: tracetree >= 0.1 && < 0.2+    ghc-options: -rtsopts -threaded++    -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a+    if os(aix)+        extra-libraries: bsd++    build-depends:+        cabal-install,+        directory,+        filepath++-- Small, fast running tests.+--+test-suite unit-tests+    import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+    default-language: Haskell2010+    ghc-options: -rtsopts -threaded++    type: exitcode-stdio-1.0+    main-is: UnitTests.hs+    hs-source-dirs: tests+    other-modules:+      UnitTests.Distribution.Client.ArbitraryInstances+      UnitTests.Distribution.Client.BuildReport+      UnitTests.Distribution.Client.Configure+      UnitTests.Distribution.Client.FetchUtils+      UnitTests.Distribution.Client.Get+      UnitTests.Distribution.Client.Glob+      UnitTests.Distribution.Client.GZipUtils+      UnitTests.Distribution.Client.IndexUtils+      UnitTests.Distribution.Client.IndexUtils.Timestamp+      UnitTests.Distribution.Client.Init+      UnitTests.Distribution.Client.Init.Golden+      UnitTests.Distribution.Client.Init.Interactive+      UnitTests.Distribution.Client.Init.NonInteractive+      UnitTests.Distribution.Client.Init.Simple+      UnitTests.Distribution.Client.Init.Utils+      UnitTests.Distribution.Client.Init.FileCreators+      UnitTests.Distribution.Client.InstallPlan+      UnitTests.Distribution.Client.JobControl+      UnitTests.Distribution.Client.ProjectConfig+      UnitTests.Distribution.Client.ProjectPlanning+      UnitTests.Distribution.Client.Store+      UnitTests.Distribution.Client.Tar+      UnitTests.Distribution.Client.Targets+      UnitTests.Distribution.Client.TreeDiffInstances+      UnitTests.Distribution.Client.UserConfig+      UnitTests.Distribution.Solver.Modular.Builder+      UnitTests.Distribution.Solver.Modular.RetryLog+      UnitTests.Distribution.Solver.Modular.Solver+      UnitTests.Distribution.Solver.Modular.DSL+      UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils+      UnitTests.Distribution.Solver.Modular.WeightedPSQ+      UnitTests.Distribution.Solver.Types.OptionalStanza+      UnitTests.Options+      UnitTests.TempTestDir++    build-depends:+          array,+          bytestring,+          cabal-install,+          Cabal-tree-diff,+          Cabal-QuickCheck,+          containers,+          directory,+          filepath,+          mtl,+          network-uri >= 2.6.2.0 && <2.7,+          random,+          tar,+          time,+          zlib,+          tasty >= 1.2.3 && <1.5,+          tasty-golden >=2.3.1.1 && <2.4,+          tasty-quickcheck,+          tasty-hunit >= 0.10,+          tree-diff,+          QuickCheck >= 2.14 && <2.15+++-- Tests to run with a limited stack and heap size+-- The test suite name must be keep short cause a longer one+-- could make the build generating paths which exceeds the windows+-- max path limit (still a problem for some ghc versions)+test-suite mem-use-tests+  import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+  type: exitcode-stdio-1.0+  main-is: MemoryUsageTests.hs+  hs-source-dirs: tests+  default-language: Haskell2010++  ghc-options: -threaded -rtsopts "-with-rtsopts=-M16M -K1K"++  other-modules:+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils+    UnitTests.Distribution.Solver.Modular.MemoryUsage+    UnitTests.Options++  build-depends:+        cabal-install,+        containers,+        tasty >= 1.2.3 && <1.5,+        tasty-hunit >= 0.10+++-- Integration tests that use the cabal-install code directly+-- but still build whole projects+test-suite integration-tests2+  import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+  ghc-options: -rtsopts -threaded+  type: exitcode-stdio-1.0+  main-is: IntegrationTests2.hs+  hs-source-dirs: tests+  default-language: Haskell2010++  build-depends:+        bytestring,+        cabal-install,+        containers,+        directory,+        filepath,+        tasty >= 1.2.3 && <1.5,+        tasty-hunit >= 0.10,+        tagged++test-suite long-tests+  import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep+  ghc-options: -rtsopts -threaded+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: LongTests.hs+  default-language: Haskell2010++  other-modules:+    UnitTests.Distribution.Client.ArbitraryInstances+    UnitTests.Distribution.Client.Described+    UnitTests.Distribution.Client.DescribedInstances+    UnitTests.Distribution.Client.FileMonitor+    UnitTests.Distribution.Client.VCS+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.QuickCheck+    UnitTests.Distribution.Solver.Modular.QuickCheck.Utils+    UnitTests.Options+    UnitTests.TempTestDir++  build-depends:+        Cabal-QuickCheck,+        Cabal-described,+        cabal-install,+        containers,+        directory,+        filepath,+        hashable,+        mtl,+        network-uri >= 2.6.2.0 && <2.7,+        random,+        tagged,+        tasty >= 1.2.3 && <1.5,+        tasty-expected-failure,+        tasty-hunit >= 0.10,+        tasty-quickcheck,+        QuickCheck >= 2.14 && <2.15,+        pretty-show >= 1.6.15
changelog view
@@ -1,10 +1,16 @@ -*-change-log-*- +3.8.1.0 Mikolaj Konarski <mikolaj@well-typed.com> August 2022+	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.8.1.0.md+ 3.6.2.0 Emily Pillmore <emilypi@cohomolo.gy> October 2021 	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.2.0.md  3.6.0.0 Emily Pillmore <emilypi@cohomolo.gy> August 2021 	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.0.0.md++3.4.1.0 Emily Pillmore <emilypi@cohomolo.gy> October 2021+	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.1.0.md  3.4.0.0 Oleg Grenrus <oleg.grenrus@iki.fi> February 2021 	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md
main/Main.hs view
@@ -28,7 +28,6 @@          , FetchFlags(..), fetchCommand          , FreezeFlags(..), freezeCommand          , genBoundsCommand-         , OutdatedFlags(..), outdatedCommand          , GetFlags(..), getCommand, unpackCommand          , checkCommand          , formatCommand@@ -87,6 +86,7 @@ import qualified Distribution.Client.CmdClean     as CmdClean import qualified Distribution.Client.CmdSdist     as CmdSdist import qualified Distribution.Client.CmdListBin   as CmdListBin+import qualified Distribution.Client.CmdOutdated  as CmdOutdated import           Distribution.Client.CmdLegacy  import Distribution.Client.Install            (install)@@ -94,7 +94,6 @@ import Distribution.Client.Fetch              (fetch) import Distribution.Client.Freeze             (freeze) import Distribution.Client.GenBounds          (genBounds)-import Distribution.Client.Outdated           (outdated) import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean) import qualified Distribution.Client.Upload as Upload@@ -109,17 +108,17 @@                                               ,updateInstallDirs) import Distribution.Client.Tar                (createTarGzFile) import Distribution.Client.Types.Credentials  (Password (..))-import Distribution.Client.Init               (initCabal)+import Distribution.Client.Init               (initCmd) import Distribution.Client.Manpage            (manpageCmd) import Distribution.Client.ManpageFlags       (ManpageFlags (..))-import Distribution.Client.Utils              (determineNumJobs-                                              ,relaxEncodingErrors-                                              )+import Distribution.Client.Utils+         ( determineNumJobs, relaxEncodingErrors )+import Distribution.Client.Version+         ( cabalInstallVersion )  import Distribution.Package (packageId) import Distribution.PackageDescription          ( BuildType(..), Executable(..), buildable )-import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )  import Distribution.PackageDescription.PrettyPrint          ( writeGenericPackageDescription )@@ -138,6 +137,7 @@          , getPersistBuildConfig, interpretPackageDbFlags          , tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) import Distribution.Simple.Program (defaultProgramDb                                    ,configureAllKnownPrograms                                    ,simpleProgramInvocation@@ -146,14 +146,13 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils          ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler-         , findPackageDesc, tryFindPackageDesc )+         , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity          ( normal ) import Distribution.Version          ( Version, mkVersion, orLaterVersion )-import qualified Paths_cabal_install (version)  import Distribution.Compat.ResponseFile import System.Environment       (getArgs, getProgName)@@ -161,11 +160,12 @@                                 , takeExtension, (</>), (<.>) ) import System.IO                ( BufferMode(LineBuffering), hSetBuffering                                 , stderr, stdout )-import System.Directory         (doesFileExist, getCurrentDirectory)+import System.Directory         ( doesFileExist, getCurrentDirectory+                                , withCurrentDirectory) import Data.Monoid              (Any(..)) import Control.Exception        (try)-import Data.Version             (showVersion) + -- | Entry point -- main :: IO ()@@ -220,9 +220,9 @@                   ++ "defaults if you run 'cabal update'."     printOptionsList = putStr . unlines     printErrors errs = dieNoVerbosity $ intercalate "\n" errs-    printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version+    printNumericVersion = putStrLn $ display cabalInstallVersion     printVersion        = putStrLn $ "cabal-install version "-                                  ++ showVersion Paths_cabal_install.version+                                  ++ display cabalInstallVersion                                   ++ "\ncompiled using version "                                   ++ display cabalVersion                                   ++ " of the Cabal library "@@ -233,14 +233,14 @@       , regularCmd infoCommand infoAction       , regularCmd fetchCommand fetchAction       , regularCmd getCommand getAction-      , hiddenCmd  unpackCommand unpackAction+      , regularCmd unpackCommand unpackAction       , regularCmd checkCommand checkAction       , regularCmd uploadCommand uploadAction       , regularCmd reportCommand reportAction       , regularCmd initCommand initAction       , regularCmd userConfigCommand userConfigAction       , regularCmd genBoundsCommand genBoundsAction-      , regularCmd outdatedCommand outdatedAction+      , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction       , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref       , hiddenCmd  formatCommand formatAction       , hiddenCmd  actAsSetupCommand actAsSetupAction@@ -694,7 +694,7 @@         , configHcPath     = listHcPath listFlags         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  compProgdb <- if listNeedsCompiler listFlags +  compProgdb <- if listNeedsCompiler listFlags       then do           (comp, _, progdb) <- configCompilerAux' configFlags           return (Just (comp, progdb))@@ -778,17 +778,6 @@                 comp platform progdb                 globalFlags' freezeFlags -outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()-outdatedAction outdatedFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (outdatedVerbosity outdatedFlags)-  config <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, _progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    outdated verbosity outdatedFlags repoContext-             comp platform- uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do   config <- loadConfig verbosity (globalConfigFile globalFlags)@@ -920,24 +909,33 @@  initAction :: InitFlags -> [String] -> Action initAction initFlags extraArgs globalFlags = do-  let verbosity = fromFlag (initVerbosity initFlags)-  when (extraArgs /= []) $-    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs-  config <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags  = savedConfigureFlags config `mappend`-                     -- override with `--with-compiler` from CLI if available-                     mempty { configHcPath = initHcPath initFlags }-  let initFlags'   = savedInitFlags      config `mappend` initFlags-  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, progdb) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    initCabal verbosity-            (configPackageDB' configFlags)-            repoContext-            comp-            progdb-            initFlags'+  -- it takes the first value within extraArgs (if there's one)+  -- and uses it as the root directory for the new project+  case extraArgs of+    [] -> initAction'+    [projectDir] -> do+      createDirectoryIfMissingVerbose verbosity True projectDir+      withCurrentDirectory projectDir initAction'+    _ -> die' verbosity $+      "'init' only takes a single, optional, extra " +++      "argument for the project root directory"+  where+    initAction' = do+      confFlags <- loadConfigOrSandboxConfig verbosity globalFlags+      -- override with `--with-compiler` from CLI if available+      let confFlags' = savedConfigureFlags confFlags `mappend` compFlags+          initFlags' = savedInitFlags confFlags `mappend` initFlags+          globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags +      (comp, _, progdb) <- configCompilerAux' confFlags'++      withRepoContext verbosity globalFlags' $ \repoContext ->+        initCmd verbosity (configPackageDB' confFlags')+          repoContext comp progdb initFlags'++    verbosity = fromFlag (initVerbosity initFlags)+    compFlags = mempty { configHcPath = initHcPath initFlags }+ userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do   let verbosity  = fromFlag (userConfigVerbosity ucflags)@@ -974,7 +972,7 @@ manpageAction commands flags extraArgs _ = do   let verbosity = fromFlag (manpageVerbosity flags)   unless (null extraArgs) $-    die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs+    die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs   pname <- getProgName   let cabalCmd = if takeExtension pname == ".exe"                  then dropExtension pname
src/Distribution/Client/BuildReports/Anonymous.hs view
@@ -25,6 +25,7 @@     parseBuildReport,     parseBuildReportList,     showBuildReport,+    cabalInstallID --    showList,   ) where @@ -33,14 +34,13 @@  import Distribution.CabalSpecVersion import Distribution.Client.BuildReports.Types-import Distribution.Client.Utils              (cabalInstallVersion)+import Distribution.Client.Version            (cabalInstallVersion) import Distribution.Compiler                  (CompilerId (..)) import Distribution.FieldGrammar-import Distribution.Fields                    (readFields, showFields)-import Distribution.Fields.ParseResult        (ParseResult, parseFatalFailure, runParseResult)+import Distribution.Fields                    import Distribution.Package                   (PackageIdentifier (..), mkPackageName) import Distribution.PackageDescription        (FlagAssignment)-import Distribution.Parsec                    (PError (..), zeroPos)+import Distribution.Parsec import Distribution.System                    (Arch, OS)  import qualified Distribution.Client.BuildReports.Lens as L@@ -154,4 +154,4 @@ -- Pretty-printing  showBuildReport :: BuildReport -> String-showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs+showBuildReport = showFields (const NoComment) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs
src/Distribution/Client/Check.hs view
@@ -68,7 +68,7 @@     --          ghc-options: -Wall -Werror     --      checkPackages will yield a warning on the last line, but it     --      would not on each individual branch.-    --      Hovever, this is the same way hackage does it, so we will yield+    --      However, this is the same way hackage does it, so we will yield     --      the exact same errors as it will.     let pkg_desc = flattenPackageDescription ppd     ioChecks <- checkPackageFiles verbosity pkg_desc "."
src/Distribution/Client/CmdBench.hs view
@@ -41,7 +41,7 @@ benchCommand :: CommandUI (NixStyleFlags ()) benchCommand = CommandUI {   commandName         = "v2-bench",-  commandSynopsis     = "Run benchmarks",+  commandSynopsis     = "Run benchmarks.",   commandUsage        = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ],   commandDescription  = Just $ \_ -> wrapText $         "Runs the specified benchmarks, first ensuring they are up to "
src/Distribution/Client/CmdBuild.hs view
@@ -14,6 +14,8 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.ProjectFlags+         ( removeIgnoreProjectOption ) import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetProblem          ( TargetProblem (..), TargetProblem' )@@ -25,11 +27,13 @@          ( GlobalFlags, ConfigFlags(..), yesNoOpt ) import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives, option, optionName )+         ( CommandUI(..), usageAlternatives, option ) import Distribution.Verbosity          ( normal ) import Distribution.Simple.Utils          ( wrapText, die' )+import Distribution.Client.ScriptUtils+         ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )  import qualified Data.Map as Map @@ -67,7 +71,7 @@      ++ "(including dependencies as needed)\n"    , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+  , commandOptions      = removeIgnoreProjectOption                         . nixStyleOptions (\showOrParseArgs ->     [ option [] ["only-configure"]         "Instead of performing a full build just run the configure step"@@ -93,7 +97,8 @@ -- "Distribution.Client.ProjectOrchestration" -- buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()-buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do+buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags+  = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do     -- TODO: This flags defaults business is ugly     let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags                                  <> buildOnlyConfigure buildFlags)@@ -101,11 +106,10 @@             | onlyConfigure = TargetActionConfigure             | otherwise = TargetActionBuild -    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    targetSelectors <--      either (reportTargetSelectorProblems verbosity) return-      =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings+    baseCtx <- case targetCtx of+      ProjectContext             -> return ctx+      GlobalContext              -> return ctx+      ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta      buildCtx <-       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do@@ -139,8 +143,6 @@     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags-                  mempty -- ClientInstallFlags, not needed here  -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
src/Distribution/Client/CmdClean.hs view
@@ -8,6 +8,8 @@     ( DistDirLayout(..), defaultDistDirLayout ) import Distribution.Client.ProjectConfig     ( findProjectRoot )+import Distribution.Client.ScriptUtils+    ( getScriptCacheDirectoryRoot ) import Distribution.Client.Setup     ( GlobalFlags ) import Distribution.ReadE ( succeedReadE )@@ -22,9 +24,14 @@ import Distribution.Verbosity     ( normal ) +import Control.Monad+    ( forM, forM_, mapM )+import qualified Data.Set as Set import System.Directory     ( removeDirectoryRecursive, removeFile-    , doesDirectoryExist, getDirectoryContents )+    , doesDirectoryExist, doesFileExist+    , getDirectoryContents, listDirectory+    , canonicalizePath ) import System.FilePath     ( (</>) ) @@ -80,16 +87,21 @@         mdistDirectory = flagToMaybe cleanDistDir         mprojectFile   = flagToMaybe cleanProjectFile -    unless (null extraArgs) $-        die' verbosity $ "'clean' doesn't take any extra arguments: "-                         ++ unwords extraArgs+    -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)+    --+    -- For now assume all files passed are the names of scripts+    notScripts <- filterM (fmap not . doesFileExist) extraArgs+    unless (null notScripts) $+        die' verbosity $ "'clean' extra arguments should be script files: "+                         ++ unwords notScripts      projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile      let distLayout = defaultDistDirLayout projectRoot mdistDirectory -    if saveConfig-        then do+    -- Do not clean a project if just running a script in it's directory+    when (null extraArgs || isJust mdistDirectory) $ do+        if saveConfig then do             let buildRoot = distBuildRootDirectory distLayout              buildRootExists <- doesDirectoryExist buildRoot@@ -103,7 +115,24 @@             info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")             handleDoesNotExist () $ removeDirectoryRecursive distRoot -    removeEnvFiles (distProjectRootDirectory distLayout)+        removeEnvFiles (distProjectRootDirectory distLayout)++    -- Clean specified script build caches and orphaned caches.+    -- There is currently no good way to specify to only clean orphaned caches.+    -- It would be better as part of an explicit gc step (see issue #3333)+    toClean  <- Set.fromList <$> mapM canonicalizePath extraArgs+    cacheDir <- getScriptCacheDirectoryRoot+    existsCD <- doesDirectoryExist cacheDir+    caches   <- if existsCD then listDirectory cacheDir else return []+    paths    <- fmap concat . forM caches $ \cache -> do+        let locFile = cacheDir </> cache </> "scriptlocation"+        exists <- doesFileExist locFile+        if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []+    forM_ paths $ \(cache, script) -> do+        exists <- doesFileExist script+        when (not exists || script `Set.member` toClean) $ do+            info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")+            removeDirectoryRecursive cache  removeEnvFiles :: FilePath -> IO () removeEnvFiles dir =
src/Distribution/Client/CmdConfigure.hs view
@@ -4,6 +4,7 @@ module Distribution.Client.CmdConfigure (     configureCommand,     configureAction,+    configureAction',   ) where  import Distribution.Client.Compat.Prelude@@ -11,33 +12,40 @@  import System.Directory import System.FilePath-import qualified Data.Map as Map +import Distribution.Simple.Flag import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig-         ( writeProjectLocalExtraConfig )+         ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig )+import Distribution.Client.ProjectFlags+         ( removeIgnoreProjectOption )  import Distribution.Client.NixStyleOptions          ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) ) import Distribution.Verbosity          ( normal )  import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives, optionName )+         ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils-         ( wrapText, notice )+         ( wrapText, notice, die' )  import Distribution.Client.DistDirLayout          ( DistDirLayout(..) )+import Distribution.Client.RebuildMonad (runRebuild)+import Distribution.Client.ProjectConfig.Types+import Distribution.Client.HttpUtils+import Distribution.Utils.NubList+         ( fromNubList )+import Distribution.Types.CondTree+         ( CondTree (..) )  configureCommand :: CommandUI (NixStyleFlags ()) configureCommand = CommandUI {   commandName         = "v2-configure",-  commandSynopsis     = "Add extra project configuration",+  commandSynopsis     = "Add extra project configuration.",   commandUsage        = usageAlternatives "v2-configure" [ "[FLAGS]" ],   commandDescription  = Just $ \_ -> wrapText $         "Adjust how the project is built by setting additional package flags "@@ -69,11 +77,11 @@      ++ "    Adjust the project configuration to use the given compiler\n"      ++ "    program and check the resulting configuration works.\n"      ++ "  " ++ pname ++ " v2-configure\n"-     ++ "    Reset the local configuration to empty and check the overall\n"-     ++ "    project configuration works.\n"+     ++ "    Reset the local configuration to empty. To check that the\n"+     ++ "    project configuration works, use 'cabal build'.\n"    , commandDefaultFlags = defaultNixStyleFlags ()-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+  , commandOptions      = removeIgnoreProjectOption                         . nixStyleOptions (const [])   } @@ -88,66 +96,58 @@ -- "Distribution.Client.ProjectOrchestration" -- configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do-    --TODO: deal with _extraArgs, since flags with wrong syntax end up there--    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    -- Write out the @cabal.project.local@ so it gets picked up by the-    -- planning phase. If old config exists, then print the contents-    -- before overwriting+configureAction flags@NixStyleFlags {..} extraArgs globalFlags = do+    (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags -    let localFile = distProjectFile (distDirLayout baseCtx) "local"-        -- | Chooses cabal.project.local~, or if it already exists-        -- cabal.project.local~0, cabal.project.local~1 etc.-        firstFreeBackup = firstFreeBackup' (0 :: Int)-        firstFreeBackup' i = do-          let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1))-          exists <- doesFileExist backup-          if exists-            then firstFreeBackup' (i + 1)-            else return backup-        dryRun = buildSettingDryRun (buildSettings baseCtx)-              || buildSettingOnlyDownload (buildSettings baseCtx)+    if shouldNotWriteFile baseCtx+      then notice v "Config file not written due to flag(s)."+      else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig+  where+    v = fromFlagOrDefault normal (configVerbosity configFlags) -    if dryRun-       then notice verbosity "Config file not written due to flag(s)."-       else do-          -- If cabal.project.local already exists, back up to cabal.project.local~[n]-          exists <- doesFileExist localFile-          when exists $ do-              backup <- firstFreeBackup-              notice verbosity $-                quote (takeFileName localFile) <> " already exists, backing it up to "-                <> quote (takeFileName backup) <> "."-              copyFile localFile backup-          writeProjectLocalExtraConfig (distDirLayout baseCtx)-                                       cliConfig+configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)+configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do+    --TODO: deal with _extraArgs, since flags with wrong syntax end up there -    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan ->+    baseCtx <- establishProjectBaseContext v cliConfig OtherCommand -            -- TODO: Select the same subset of targets as 'CmdBuild' would-            -- pick (ignoring, for example, executables in libraries-            -- we depend on). But we don't want it to fail, so actually we-            -- have to do it slightly differently from build.-            return (elaboratedPlan, Map.empty)+    let localFile  = distProjectFile (distDirLayout baseCtx) "local"+    -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~+    let backups = fromFlagOrDefault True  $ configBackup configExFlags+        appends = fromFlagOrDefault False $ configAppend configExFlags+        backupFile = localFile <> "~" -    let baseCtx' = baseCtx {-                      buildSettings = (buildSettings baseCtx) {-                        buildSettingDryRun = True-                      }-                    }+    if shouldNotWriteFile baseCtx+      then+        return (baseCtx, cliConfig)+      else do+        exists <- doesFileExist localFile+        when (exists && backups) $ do+          notice v $+            quote (takeFileName localFile) <> " already exists, backing it up to "+            <> quote (takeFileName backupFile) <> "."+          copyFile localFile backupFile -    -- TODO: Hmm, but we don't have any targets. Currently this prints-    -- what we would build if we were to build everything. Could pick-    -- implicit target like "."-    ---    -- TODO: should we say what's in the project (+deps) as a whole?-    printPlan verbosity baseCtx' buildCtx+         -- If the flag @configAppend@ is set to true, append and do not overwrite+        if exists && appends+          then do+            httpTransport <- configureTransport v+                     (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)+                     (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)+            (CondNode conf imps bs)  <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $+              readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx)+            when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update"+            return (baseCtx, conf <> cliConfig)+          else+            return (baseCtx, cliConfig)   where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    v = fromFlagOrDefault normal (configVerbosity configFlags)     cliConfig = commandLineFlagsToProjectConfig globalFlags flags                   mempty -- ClientInstallFlags, not needed here     quote s = "'" <> s <> "'" +-- Config file should not be written when certain flags are present+shouldNotWriteFile :: ProjectBaseContext -> Bool+shouldNotWriteFile baseCtx =+     buildSettingDryRun (buildSettings baseCtx)+  || buildSettingOnlyDownload (buildSettings baseCtx)
src/Distribution/Client/CmdErrorMessages.hs view
@@ -94,7 +94,7 @@   ------------------------------------------------------- Renderering for a few project and package types+-- Rendering for a few project and package types --  renderTargetSelector :: TargetSelector -> String@@ -201,7 +201,7 @@   ---------------------------------------------------------- Renderering error messages for TargetProblem+-- Rendering error messages for TargetProblem --  -- | Default implementation of 'reportTargetProblems' simply renders one problem per line.@@ -302,7 +302,7 @@   --------------------------------------------------------------- Renderering error messages for TargetProblemNoneEnabled+-- Rendering error messages for TargetProblemNoneEnabled --  -- | Several commands have a @TargetProblemNoneEnabled@ problem constructor.@@ -330,10 +330,13 @@               [ "the " ++ showComponentName availableTargetComponentName               | AvailableTarget {availableTargetComponentName} <- targets' ]          ++ plural (listPlural targets') " is " " are "-         ++ "not available because the solver did not find a plan that "-         ++ "included the " ++ renderOptionalStanza Plural stanza-         ++ ". Force the solver to enable this for all packages by adding the "-         ++ "line 'tests: True' to the 'cabal.project.local' file."+         ++ "not available because the solver picked a plan that does not "+         ++ "include the " ++ renderOptionalStanza Plural stanza+         ++ ", perhaps because no such plan exists. To see the error message "+         ++ "explaining the problems with such plans, force the solver to "+         ++ "include the " ++ renderOptionalStanza Plural stanza ++ " for all "+         ++ "packages, by adding the line 'tests: True' to the "+         ++ "'cabal.project.local' file."         (TargetNotBuildable, _) ->             renderListCommaAnd               [ "the " ++ showComponentName availableTargetComponentName@@ -367,7 +370,7 @@       )  --------------------------------------------------------------- Renderering error messages for TargetProblemNoneEnabled+-- Rendering error messages for TargetProblemNoneEnabled --  -- | Several commands have a @TargetProblemNoTargets@ problem constructor.@@ -402,7 +405,7 @@         error $ "renderTargetProblemNoTargets: " ++ show ts  -------------------------------------------------------------- Renderering error messages for CannotPruneDependencies+-- Rendering error messages for CannotPruneDependencies --  renderCannotPruneDependencies :: CannotPruneDependencies -> String@@ -433,7 +436,7 @@            ++ "    (name of library, executable, test-suite or benchmark)\n"            ++ " - build Data.Foo       -- module name\n"            ++ " - build Data/Foo.hsc   -- file name\n\n"-           ++ "An ambigious target can be qualified by package, component\n"+           ++ "An ambiguous target can be qualified by package, component\n"            ++ "and/or component kind (lib|exe|test|bench|flib)\n"            ++ " - build foo:tests      -- component qualified by package\n"            ++ " - build tests:Data.Foo -- module qualified by component\n"
src/Distribution/Client/CmdExec.hs view
@@ -27,6 +27,9 @@   ( ConfigFlags(configVerbosity)   , GlobalFlags   )+import Distribution.Client.ProjectFlags+  ( removeIgnoreProjectOption+  ) import Distribution.Client.ProjectOrchestration   ( ProjectBuildContext(..)   , runProjectPreBuildPhase@@ -49,8 +52,7 @@   , ElaboratedSharedConfig(..)   ) import Distribution.Simple.Command-  ( CommandUI(..), optionName-  )+  ( CommandUI(..) ) import Distribution.Simple.Program.Db   ( modifyProgramSearchPath   , requireProgram@@ -115,7 +117,7 @@     ++ " to choose an appropriate version of ghc and to include any"     ++ " ghc-specific flags requested."   , commandNotes = Nothing-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+  , commandOptions      = removeIgnoreProjectOption                         . nixStyleOptions (const [])   , commandDefaultFlags = defaultNixStyleFlags ()   }
src/Distribution/Client/CmdHaddock.hs view
@@ -24,18 +24,23 @@ import Distribution.Client.Setup          ( GlobalFlags, ConfigFlags(..) ) import Distribution.Simple.Setup-         ( HaddockFlags(..), fromFlagOrDefault )+         ( HaddockFlags(..), fromFlagOrDefault, trueArg ) import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )+         ( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option ) import Distribution.Verbosity          ( normal ) import Distribution.Simple.Utils-         ( wrapText, die' )+         ( wrapText, die', notice )+import Distribution.Simple.Flag (Flag(..)) -haddockCommand :: CommandUI (NixStyleFlags ())+import qualified System.Exit (exitSuccess)++newtype ClientHaddockFlags = ClientHaddockFlags { openInBrowser :: Flag Bool }++haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags) haddockCommand = CommandUI {   commandName         = "v2-haddock",-  commandSynopsis     = "Build Haddock documentation",+  commandSynopsis     = "Build Haddock documentation.",   commandUsage        = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],   commandDescription  = Just $ \_ -> wrapText $         "Build Haddock documentation for the specified packages within the "@@ -58,21 +63,33 @@         "Examples:\n"      ++ "  " ++ pname ++ " v2-haddock pkgname"      ++ "    Build documentation for the package named pkgname\n"-  , commandOptions      = nixStyleOptions (const [])-  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = nixStyleOptions haddockOptions+  , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False))   }    --TODO: [nice to have] support haddock on specific components, not just    -- whole packages and the silly --executables etc modifiers. +haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags]+haddockOptions _ =+  [ option [] ["open"] "Open generated documentation in the browser"+    openInBrowser (\v f -> f { openInBrowser = v}) trueArg+  ]+ -- | The @haddock@ command is TODO. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO () haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do-    baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand+    projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand +    let baseCtx+          | fromFlagOrDefault False (openInBrowser extraFlags)+            = projCtx { buildSettings = (buildSettings projCtx) { buildSettingHaddockOpen = True } }+          | otherwise+            = projCtx+     targetSelectors <- either (reportTargetSelectorProblems verbosity) return                    =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings @@ -171,4 +188,13 @@  reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a reportBuildDocumentationTargetProblems verbosity problems =-  reportTargetProblems verbosity "build documentation for" problems+  case problems of+    [TargetProblemNoneEnabled _ _] -> do+      notice verbosity $ unwords+        [ "No documentation was generated as this package does not contain a library."+        , "Perhaps you want to use the --haddock-all flag, or one or more of the"+        , "--haddock-executables, --haddock-tests, --haddock-benchmarks or"+        , "--haddock-internal flags."+        ]+      System.Exit.exitSuccess+    _ -> reportTargetProblems verbosity "build documentation for" problems
src/Distribution/Client/CmdInstall.hs view
@@ -90,7 +90,7 @@ import Distribution.Client.RebuildMonad          ( runRebuild ) import Distribution.Client.InstallSymlink-         ( symlinkBinary, trySymlink )+         ( symlinkBinary, trySymlink, promptRun ) import Distribution.Client.Types.OverwritePolicy          ( OverwritePolicy (..) ) import Distribution.Simple.Flag@@ -130,6 +130,7 @@ 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)@@ -179,7 +180,7 @@ --   Exes are installed in the store like a normal dependency, then they are --   symlinked/copied in the directory specified by --installdir. --   To do this we need a dummy projectBaseContext containing the targets as---   estra packages and using a temporary dist directory.+--   extra packages and using a temporary dist directory. -- * libraries --   Libraries install through a similar process, but using GHC environment --   files instead of symlinks. This means that 'v2-install'ing libraries@@ -483,7 +484,7 @@   -> 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 @@   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 @@   -> FilePath   -> InstallMethod   -> ( UnitId-     , [(ComponentTarget, [TargetSelector])] )+     , [(ComponentTarget, NonEmpty TargetSelector)] )   -> IO () installUnitExes verbosity overwritePolicy                 mkSourceBinDir mkExeName mkFinalExeName@@ -780,7 +781,7 @@               <> "Use --overwrite-policy=always to overwrite."             -- This shouldn't even be possible, but we keep it in case             -- symlinking/copying logic changes-            AlwaysOverwrite ->+            _ ->               case installMethod of                 InstallMethodSymlink -> "Symlinking"                 InstallMethodCopy    ->@@ -815,7 +816,8 @@   exists <- doesPathExist destination   case (exists, overwritePolicy) of     (True , NeverOverwrite ) -> pure False-    (True , AlwaysOverwrite) -> remove >> copy+    (True , AlwaysOverwrite) -> overwrite+    (True , PromptOverwrite) -> maybeOverwrite     (False, _              ) -> copy   where     source      = sourceDir </> exeName@@ -826,17 +828,24 @@       then removeDirectory destination       else removeFile      destination     copy = copyFile source destination >> pure True+    overwrite :: IO Bool+    overwrite = remove >> copy+    maybeOverwrite :: IO Bool+    maybeOverwrite+      = promptRun+        "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"+        overwrite  -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. 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]
src/Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -65,7 +65,7 @@   , option [] ["overwrite-policy"]     "How to handle already existing symlinks."     cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })-    $ reqArg "always|never"+    $ reqArg "always|never|prompt"         (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec))          (map prettyShow . flagToList)   , option [] ["install-method"]
src/Distribution/Client/CmdListBin.hs view
@@ -6,6 +6,14 @@ module Distribution.Client.CmdListBin (     listbinCommand,     listbinAction,++    -- * Internals exposed for testing+    selectPackageTargets,+    selectComponentTarget,+    noComponentsProblem,+    matchesMultipleProblem,+    multipleTargetsProblem,+    componentNotRightKindProblem ) where  import Distribution.Client.Compat.Prelude@@ -14,26 +22,24 @@ import Distribution.Client.CmdErrorMessages        (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,        renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)-import Distribution.Client.DistDirLayout         (DistDirLayout (..), ProjectRoot (..))+import Distribution.Client.DistDirLayout         (DistDirLayout (..)) import Distribution.Client.NixStyleOptions        (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)-import Distribution.Client.ProjectConfig-       (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig)-import Distribution.Client.ProjectFlags          (ProjectFlags (..)) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.ScriptUtils+       (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors) import Distribution.Client.Setup                 (GlobalFlags (..)) 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) import Distribution.Types.UnqualComponentName    (UnqualComponentName) import Distribution.Verbosity                    (silent, verboseStderr)-import System.Directory                          (getCurrentDirectory) import System.FilePath                           ((<.>), (</>))  import qualified Data.Map                                as Map@@ -49,11 +55,11 @@ listbinCommand :: CommandUI (NixStyleFlags ()) listbinCommand = CommandUI     { commandName = "list-bin"-    , commandSynopsis = "list path to a single executable."+    , commandSynopsis = "List the path to a single executable."     , commandUsage = \pname ->         "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"     , commandDescription  = Just $ \_ -> wrapText-        "List path to a build product."+        "List the path to a build product."     , commandNotes = Nothing     , commandDefaultFlags = defaultNixStyleFlags ()     , commandOptions      = nixStyleOptions (const [])@@ -65,19 +71,18 @@  listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () listbinAction flags@NixStyleFlags{..} args globalFlags = do-    -- fail early if multiple target selectors specified-    target <- case args of-        []  -> die' verbosity "One target is required, none provided"-        [x] -> return x-        _   -> die' verbosity "One target is required, given multiple"--    -- configure-    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject-    let localPkgs = localPackages baseCtx+  -- fail early if multiple target selectors specified+  target <- case args of+      []  -> die' verbosity "One target is required, none provided"+      [x] -> return x+      _   -> die' verbosity "One target is required, given multiple" -    -- elaborate target selectors-    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-        =<< readTargetSelectors localPkgs (Just ExeKind) [target]+  -- configure and elaborate target selectors+  withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags $ \targetCtx ctx targetSelectors -> do+    baseCtx <- case targetCtx of+      ProjectContext             -> return ctx+      GlobalContext              -> return ctx+      ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta      buildCtx <-       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do@@ -110,7 +115,7 @@                                     elaboratedPlan             return (elaboratedPlan', targets) -    (selectedUnitId, _selectedComponent) <-+    (selectedUnitId, selectedComponent) <-       -- Slight duplication with 'runProjectPreBuildPhase'.       singleComponentOrElse         (die' verbosity $ "No or multiple targets given, but the run "@@ -123,37 +128,25 @@         Nothing  -> die' verbosity "No or multiple targets given..."         Just gpp -> return $ IP.foldPlanPackage             (const []) -- IPI don't have executables-            (elaboratedPackage distDirLayout (elaboratedShared buildCtx))+            (elaboratedPackage (distDirLayout baseCtx) (elaboratedShared buildCtx) selectedComponent)             gpp      case binfiles of+        []     -> die' verbosity "No target found"         [exe] -> putStrLn exe-        _     -> die' verbosity "No or multiple targets given"+        _ -> die' verbosity "Multiple targets found"   where     defaultVerbosity = verboseStderr silent     verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig) -    withProject :: IO (ProjectBaseContext, DistDirLayout)-    withProject = do-        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand-        return (baseCtx, distDirLayout baseCtx)--    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)-    withoutProject config = do-        cwd <- getCurrentDirectory-        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand-        return (baseCtx, distDirLayout baseCtx)-     -- this is copied from     elaboratedPackage         :: DistDirLayout         -> ElaboratedSharedConfig+        -> UnqualComponentName         -> ElaboratedConfiguredPackage         -> [FilePath]-    elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of+    elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of         ElabPackage pkg ->             [ bin             | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg)@@ -165,11 +158,15 @@         dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)          bin_file c = case c of-            CD.ComponentExe s   -> [bin_file' s]-            CD.ComponentTest s  -> [bin_file' s]-            CD.ComponentBench s -> [bin_file' s]-            CD.ComponentFLib s  -> [flib_file' s]-            _                -> []+            CD.ComponentExe s+               | s == selectedComponent -> [bin_file' s]+            CD.ComponentTest s+               | s == selectedComponent -> [bin_file' s]+            CD.ComponentBench s+               | s == selectedComponent -> [bin_file' s]+            CD.ComponentFLib s+               | s == selectedComponent -> [flib_file' s]+            _ -> []          plat :: Platform         plat = pkgConfigPlatform elaboratedSharedConfig@@ -210,17 +207,21 @@                      -> [AvailableTarget k] -> Either ListBinTargetProblem [k] selectPackageTargets targetSelector targets -    -- If there is exactly one buildable executable then we select that+  -- If there is a single executable component, select that. See #7403   | [target] <- targetsExesBuildable   = Right [target] +  -- Otherwise, if there is a single executable-like component left, select that.+  | [target] <- targetsExeLikesBuildable+  = Right [target]+     -- but fail if there are multiple buildable executables.-  | not (null targetsExesBuildable)-  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')+  | not (null targetsExeLikesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')      -- If there are executables but none are buildable then we report those-  | not (null targetsExes)-  = Left (TargetProblemNoneEnabled targetSelector targetsExes)+  | not (null targetsExeLikes')+  = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')      -- If there are no executables but some other targets then we report that   | not (null targets)@@ -230,16 +231,21 @@   | otherwise   = Left (TargetProblemNoTargets targetSelector)   where-    -- Targets that can be executed-    targetsExecutableLike =-      concatMap (\kind -> filterTargetsKind kind targets)-                [ExeKind, TestKind, BenchKind]-    (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike+    -- Targets that are precisely executables+    targetsExes = filterTargetsKind ExeKind targets+    targetsExesBuildable = selectBuildableTargets targetsExes -    targetsExes             = forgetTargetsDetail targetsExecutableLike+    -- Any target that could be executed+    targetsExeLikes = targetsExes+                   ++ filterTargetsKind TestKind targets+                   ++ filterTargetsKind BenchKind targets +    (targetsExeLikesBuildable,+     targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes +    targetsExeLikes'             = forgetTargetsDetail targetsExeLikes++ -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. --@@ -341,7 +347,7 @@ 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) =
+ src/Distribution/Client/CmdOutdated.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.CmdOutdated+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'outdated' command. Checks for outdated+-- dependencies in the package description file or freeze file.+-----------------------------------------------------------------------------++module Distribution.Client.CmdOutdated+    ( outdatedCommand, outdatedAction+    , ListOutdatedSettings(..), listOutdated )+where++import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens+    ( _1, _2 )+import Prelude ()++import Distribution.Client.Config+    ( SavedConfig(savedGlobalFlags, savedConfigureFlags+                 , savedConfigureExFlags) )+import Distribution.Client.IndexUtils as IndexUtils+import Distribution.Client.DistDirLayout+    ( defaultDistDirLayout+    , DistDirLayout(distProjectRootDirectory, distProjectFile) )+import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectConfig.Legacy+    ( instantiateProjectConfigSkeleton )+import Distribution.Client.ProjectFlags+    ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags+    , removeIgnoreProjectOption )+import Distribution.Client.RebuildMonad+    ( runRebuild )+import Distribution.Client.Sandbox+    ( loadConfigOrSandboxConfig )+import Distribution.Client.Setup+import Distribution.Client.Targets+    ( userToPackageConstraint, UserConstraint )+import Distribution.Client.Types.SourcePackageDb as SourcePackageDb+import Distribution.Solver.Types.PackageConstraint+    ( packageConstraintToDependency )+import Distribution.Client.Sandbox.PackageEnvironment+    ( loadUserConfig )+import Distribution.Utils.Generic+    ( safeLast, wrapText )++import Distribution.Package+    ( PackageName, packageVersion )+import Distribution.PackageDescription+    ( allBuildDepends )+import Distribution.PackageDescription.Configuration+    ( finalizePD )+import Distribution.Simple.Compiler+    ( Compiler, compilerInfo )+import Distribution.Simple.Setup+    ( optionVerbosity, trueArg )+import Distribution.Simple.Utils+    ( die', notice, debug, tryFindPackageDesc )+import Distribution.System+    ( Platform (..) )+import Distribution.Types.ComponentRequestedSpec+    ( ComponentRequestedSpec(..) )+import Distribution.Types.Dependency+    ( Dependency(..) )+import Distribution.Verbosity+    ( silent, normal )+import Distribution.Version+    ( Version, VersionInterval (..), VersionRange, LowerBound(..)+    , UpperBound(..) , asVersionIntervals, majorBoundVersion )+import Distribution.Types.PackageVersionConstraint+    ( PackageVersionConstraint (..), simplifyPackageVersionConstraint )+import Distribution.Simple.Flag+    ( Flag(..), flagToMaybe, fromFlagOrDefault, toFlag )+import Distribution.Simple.Command+    ( ShowOrParseArgs, OptionField, CommandUI(..), optArg, option, reqArg, liftOptionL )+import Distribution.Simple.PackageDescription+    ( readGenericPackageDescription )+import qualified Distribution.Compat.CharParsing as P+import Distribution.ReadE+    ( parsecToReadE )+import Distribution.Client.HttpUtils+import Distribution.Utils.NubList+         ( fromNubList )++import qualified Data.Set as S+import System.Directory+    ( getCurrentDirectory, doesFileExist )++-------------------------------------------------------------------------------+-- Command+-------------------------------------------------------------------------------++outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags)+outdatedCommand = CommandUI+  { commandName = "outdated"+  , commandSynopsis = "Check for outdated dependencies."+  , commandDescription  = Just $ \_ -> wrapText $+      "Checks for outdated dependencies in the package description file "+      ++ "or freeze file"+  , commandNotes = Nothing+  , commandUsage = \pname ->+      "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n"+  , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags)+  , commandOptions      = \showOrParseArgs ->+        map (liftOptionL _1)+            (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) +++        map (liftOptionL _2) (outdatedOptions showOrParseArgs)+  }++-------------------------------------------------------------------------------+-- Flags+-------------------------------------------------------------------------------++data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone+                             | IgnoreMajorVersionBumpsAll+                             | IgnoreMajorVersionBumpsSome [PackageName]++instance Monoid IgnoreMajorVersionBumps where+  mempty  = IgnoreMajorVersionBumpsNone+  mappend = (<>)++instance Semigroup IgnoreMajorVersionBumps where+  IgnoreMajorVersionBumpsNone       <> r                               = r+  l@IgnoreMajorVersionBumpsAll      <> _                               = l+  l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone     = l+  (IgnoreMajorVersionBumpsSome   _) <> r@IgnoreMajorVersionBumpsAll    = r+  (IgnoreMajorVersionBumpsSome   a) <> (IgnoreMajorVersionBumpsSome b) =+    IgnoreMajorVersionBumpsSome (a ++ b)++data OutdatedFlags = OutdatedFlags+  { outdatedVerbosity     :: Flag Verbosity+  , outdatedFreezeFile    :: Flag Bool+  , outdatedNewFreezeFile :: Flag Bool+  , outdatedSimpleOutput  :: Flag Bool+  , outdatedExitCode      :: Flag Bool+  , outdatedQuiet         :: Flag Bool+  , outdatedIgnore        :: [PackageName]+  , outdatedMinor         :: Maybe IgnoreMajorVersionBumps+  }++defaultOutdatedFlags :: OutdatedFlags+defaultOutdatedFlags = OutdatedFlags+  { outdatedVerbosity     = toFlag normal+  , outdatedFreezeFile    = mempty+  , outdatedNewFreezeFile = mempty+  , outdatedSimpleOutput  = mempty+  , outdatedExitCode      = mempty+  , outdatedQuiet         = mempty+  , outdatedIgnore        = mempty+  , outdatedMinor         = mempty+  }++outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]+outdatedOptions _showOrParseArgs =+  [ optionVerbosity+      outdatedVerbosity+      (\v flags -> flags {outdatedVerbosity = v})+  , option [] ["freeze-file", "v1-freeze-file"]+      "Act on the freeze file"+      outdatedFreezeFile (\v flags -> flags {outdatedFreezeFile = v})+      trueArg+  , option [] ["v2-freeze-file", "new-freeze-file"]+      "Act on the new-style freeze file (default: cabal.project.freeze)"+      outdatedNewFreezeFile (\v flags -> flags {outdatedNewFreezeFile = v})+      trueArg+  , option [] ["simple-output"]+      "Only print names of outdated dependencies, one per line"+      outdatedSimpleOutput (\v flags -> flags {outdatedSimpleOutput = v})+      trueArg+  , option [] ["exit-code"]+      "Exit with non-zero when there are outdated dependencies"+      outdatedExitCode (\v flags -> flags {outdatedExitCode = v})+      trueArg+  , option ['q'] ["quiet"]+      "Don't print any output. Implies '--exit-code' and '-v0'"+      outdatedQuiet (\v flags -> flags {outdatedQuiet = v})+      trueArg+  , option [] ["ignore"]+      "Packages to ignore"+      outdatedIgnore (\v flags -> flags {outdatedIgnore = v})+      (reqArg "PKGS" pkgNameListParser (map prettyShow))+  , option [] ["minor"]+      "Ignore major version bumps for these packages"+      outdatedMinor (\v flags -> flags {outdatedMinor = v})+      ( optArg+          "PKGS"+          ignoreMajorVersionBumpsParser+          (Just IgnoreMajorVersionBumpsAll)+          ignoreMajorVersionBumpsPrinter+      )+  ]+  where+    ignoreMajorVersionBumpsPrinter :: Maybe IgnoreMajorVersionBumps+                                   -> [Maybe String]+    ignoreMajorVersionBumpsPrinter Nothing = []+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]+    ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =+      map (Just . prettyShow) pkgs++    ignoreMajorVersionBumpsParser  =+      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser++    pkgNameListParser = parsecToReadE+      ("Couldn't parse the list of package names: " ++)+      (fmap toList (P.sepByNonEmpty parsec (P.char ',')))++-------------------------------------------------------------------------------+-- Action+-------------------------------------------------------------------------------++-- | Entry point for the 'outdated' command.+outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO ()+outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStrings globalFlags = do+  config <- loadConfigOrSandboxConfig verbosity globalFlags+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+      configFlags  = savedConfigureFlags config+  withRepoContext verbosity globalFlags' $ \repoContext -> do+    when (not newFreezeFile && isJust mprojectFile) $+      die' verbosity $+        "--project-file must only be used with --v2-freeze-file."++    sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext+    (comp, platform, _progdb) <- configCompilerAux' configFlags+    deps <- if freezeFile+            then depsFromFreezeFile verbosity+            else if newFreezeFile+                then do+                       httpTransport <- configureTransport verbosity+                         (fromNubList . globalProgPathExtra $ globalFlags)+                         (flagToMaybe . globalHttpTransport $ globalFlags)+                       depsFromNewFreezeFile verbosity httpTransport comp platform mprojectFile+                else do+                  depsFromPkgDesc verbosity comp platform+    debug verbosity $ "Dependencies loaded: "+      ++ intercalate ", " (map prettyShow deps)+    let outdatedDeps = listOutdated deps sourcePkgDb+                      (ListOutdatedSettings ignorePred minorPred)+    when (not quiet) $+      showResult verbosity outdatedDeps simpleOutput+    if exitCode && (not . null $ outdatedDeps)+      then exitFailure+      else return ()+  where+    verbosity     = if quiet+                      then silent+                      else fromFlagOrDefault normal outdatedVerbosity+    freezeFile    = fromFlagOrDefault False outdatedFreezeFile+    newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile+    mprojectFile  = flagToMaybe flagProjectFileName+    simpleOutput  = fromFlagOrDefault False outdatedSimpleOutput+    quiet         = fromFlagOrDefault False outdatedQuiet+    exitCode      = fromFlagOrDefault quiet outdatedExitCode+    ignorePred    = let ignoreSet = S.fromList outdatedIgnore+                    in \pkgname -> pkgname `S.member` ignoreSet+    minorPred     = case outdatedMinor of+                      Nothing -> const False+                      Just IgnoreMajorVersionBumpsNone -> const False+                      Just IgnoreMajorVersionBumpsAll  -> const True+                      Just (IgnoreMajorVersionBumpsSome pkgs) ->+                        let minorSet = S.fromList pkgs+                        in \pkgname -> pkgname `S.member` minorSet+++-- | Print either the list of all outdated dependencies, or a message+-- that there are none.+showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()+showResult verbosity outdatedDeps simpleOutput =+  if not . null $ outdatedDeps+    then+    do when (not simpleOutput) $+         notice verbosity "Outdated dependencies:"+       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->+         let outdatedDep = if simpleOutput then prettyShow pn+                           else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"+         in notice verbosity outdatedDep+    else notice verbosity "All dependencies are up to date."++-- | Convert a list of 'UserConstraint's to a 'Dependency' list.+userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]+userConstraintsToDependencies ucnstrs =+  mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs++-- | Read the list of dependencies from the freeze file.+depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]+depsFromFreezeFile verbosity = do+  cwd        <- getCurrentDirectory+  userConfig <- loadUserConfig verbosity cwd Nothing+  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $+                userConfig+      deps    = userConstraintsToDependencies ucnstrs+  debug verbosity "Reading the list of dependencies from the freeze file"+  return deps++-- | Read the list of dependencies from the new-style freeze file.+depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> IO [PackageVersionConstraint]+depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectFile = do+  projectRoot <- either throwIO return =<<+                 findProjectRoot Nothing mprojectFile+  let distDirLayout = defaultDistDirLayout projectRoot+                      {- TODO: Support dist dir override -} Nothing+  projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do+                      pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout+                      pure $ instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty pcs+  let ucnstrs = map fst . projectConfigConstraints . projectConfigShared+                $ projectConfig+      deps    = userConstraintsToDependencies ucnstrs+      freezeFile = distProjectFile distDirLayout "freeze"+  freezeFileExists <- doesFileExist freezeFile++  unless freezeFileExists $+    die' verbosity $+      "Couldn't find a freeze file expected at: " ++ freezeFile ++ "\n\n"+      ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. "+      ++ "When one of these flags is given, we try to read the dependencies from a freeze file. "+      ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate "+      ++ "a freeze file via 'cabal freeze'."+  debug verbosity $+    "Reading the list of dependencies from the new-style freeze file " ++ freezeFile+  return deps++-- | Read the list of dependencies from the package description.+depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint]+depsFromPkgDesc verbosity comp platform = do+  cwd  <- getCurrentDirectory+  path <- tryFindPackageDesc verbosity cwd+  gpd  <- readGenericPackageDescription verbosity path+  let cinfo = compilerInfo comp+      epd = finalizePD mempty (ComponentRequestedSpec True True)+            (const True) platform cinfo [] gpd+  case epd of+    Left _        -> die' verbosity "finalizePD failed"+    Right (pd, _) -> do+      let bd = allBuildDepends pd+      debug verbosity+        "Reading the list of dependencies from the package description"+      return $ map toPVC bd+  where+    toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr++-- | Various knobs for customising the behaviour of 'listOutdated'.+data ListOutdatedSettings = ListOutdatedSettings+  { -- | Should this package be ignored?+    listOutdatedIgnorePred :: PackageName -> Bool+  , -- | Should major version bumps be ignored for this package?+    listOutdatedMinorPred  :: PackageName -> Bool+  }++-- | Find all outdated dependencies.+listOutdated :: [PackageVersionConstraint]+             -> SourcePackageDb+             -> ListOutdatedSettings+             -> [(PackageVersionConstraint, Version)]+listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) =+  mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps+  where+    isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)+    isOutdated dep@(PackageVersionConstraint pname vr)+      | ignorePred pname = Nothing+      | otherwise =+          let this   = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr+              latest = lookupLatest dep+          in (\v -> (dep, v)) `fmap` isOutdated' this latest++    isOutdated' :: [Version] -> [Version] -> Maybe Version+    isOutdated' [] _  = Nothing+    isOutdated' _  [] = Nothing+    isOutdated' this latest =+      let this'   = maximum this+          latest' = maximum latest+      in if this' < latest' then Just latest' else Nothing++    lookupLatest :: PackageVersionConstraint -> [Version]+    lookupLatest (PackageVersionConstraint pname vr)+      | minorPred pname =+        map packageVersion $ SourcePackageDb.lookupDependency sourceDb  pname (relaxMinor vr)+      | otherwise =+        map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname++    relaxMinor :: VersionRange -> VersionRange+    relaxMinor vr =+      let vis = asVersionIntervals vr+      in maybe vr relax (safeLast vis)+      where relax (VersionInterval (LowerBound v0 _) upper) =+              case upper of+                NoUpperBound     -> vr+                UpperBound _v1 _ -> majorBoundVersion v0
src/Distribution/Client/CmdRepl.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}  -- | cabal-install CLI command: repl --@@ -23,6 +23,8 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L +import Distribution.Client.DistDirLayout+         ( DistDirLayout(..) ) import Distribution.Client.NixStyleOptions          ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.CmdErrorMessages@@ -36,23 +38,22 @@ import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.ProjectBuilding          ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), withProjectOrGlobalConfig-         , projectConfigConfigFile )-import Distribution.Client.ProjectFlags-         ( flagIgnoreProject ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning        ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types        ( elabOrderExeDependencies )+import Distribution.Client.ScriptUtils+         ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..)+         , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile'+         , fakeProjectSourcePackage, lSrcpkgDescription ) import Distribution.Client.Setup          ( GlobalFlags, ConfigFlags(..) ) import qualified Distribution.Client.Setup as Client import Distribution.Client.Types-         ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )+         ( PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup-         ( fromFlagOrDefault, replOptions+         ( fromFlagOrDefault, ReplOptions(..), replOptions          , Flag(..), toFlag, falseArg ) import Distribution.Simple.Command          ( CommandUI(..), liftOptionL, usageAlternatives, option@@ -60,15 +61,13 @@ import Distribution.Compiler          ( CompilerFlavor(GHC) ) import Distribution.Simple.Compiler-         ( compilerCompatVersion )+         ( Compiler, compilerCompatVersion ) import Distribution.Package          ( Package(..), packageName, UnitId, installedUnitId )-import Distribution.PackageDescription.PrettyPrint import Distribution.Parsec          ( parsecCommaList ) import Distribution.ReadE          ( ReadE, parsecToReadE )-import qualified Distribution.SPDX.License as SPDX import Distribution.Solver.Types.SourcePackage          ( SourcePackage(..) ) import Distribution.Types.BuildInfo@@ -79,16 +78,10 @@          ( CondTree(..), traverseCondTreeC ) import Distribution.Types.Dependency          ( Dependency(..), mainLibSet )-import Distribution.Types.GenericPackageDescription-         ( emptyGenericPackageDescription )-import Distribution.Types.PackageDescription-         ( PackageDescription(..), emptyPackageDescription )-import Distribution.Types.PackageName.Magic-         ( fakePackageId ) import Distribution.Types.Library          ( Library(..), emptyLibrary ) import Distribution.Types.Version-         ( mkVersion )+         ( Version, mkVersion ) import Distribution.Types.VersionRange          ( anyVersion ) import Distribution.Utils.Generic@@ -96,23 +89,19 @@ import Distribution.Verbosity          ( normal, lessVerbose ) import Distribution.Simple.Utils-         ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist )+         ( wrapText, die', debugNoWrap ) import Language.Haskell.Extension          ( Language(..) )-import Distribution.CabalSpecVersion-         ( CabalSpecVersion (..) )  import Data.List          ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory-         ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive )+         ( doesFileExist, getCurrentDirectory ) import System.FilePath          ( (</>) ) -type ReplFlags = [String]- data EnvFlags = EnvFlags   { envPackages :: [Dependency]   , envIncludeTransitive :: Flag Bool@@ -142,7 +131,7 @@         ("couldn't parse dependencies: " ++)         (parsecCommaList parsec) -replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags))+replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags)) replCommand = Client.installCommand {   commandName         = "v2-repl",   commandSynopsis     = "Open an interactive session for the given component.",@@ -179,7 +168,7 @@      ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "         ++ "to the default component (or no component if there is no project present)\n", -  commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags),+  commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags),   commandOptions = nixStyleOptions $ \showOrParseArgs ->     map (liftOptionL _1) (replOptions showOrParseArgs) ++     map (liftOptionL _2) (envOptions showOrParseArgs)@@ -196,20 +185,43 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()-replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do-    let-      with           = withProject    cliConfig             verbosity targetStrings-      without config = withoutProject (config <> cliConfig) verbosity targetStrings--    (baseCtx, targetSelectors, finalizer, replType) <--      withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without--    when (buildSettingOnlyDeps (buildSettings baseCtx)) $+replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO ()+replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags+  = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do+    when (buildSettingOnlyDeps (buildSettings ctx)) $       die' verbosity $ "The repl command does not support '--only-dependencies'. "           ++ "You may wish to use 'build --only-dependencies' and then "           ++ "use 'repl'." +    let projectRoot = distProjectRootDirectory $ distDirLayout ctx++    baseCtx <- case targetCtx of+      ProjectContext -> return ctx+      GlobalContext  -> do+        unless (null targetStrings) $+          die' verbosity $ "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings++        let+          sourcePackage = fakeProjectSourcePackage projectRoot+            & lSrcpkgDescription . L.condLibrary+            .~ Just (CondNode library [baseDep] [])+          library = emptyLibrary { libBuildInfo = lBuildInfo }+          lBuildInfo = emptyBuildInfo+            { targetBuildDepends = [baseDep]+            , defaultLanguage = Just Haskell2010+            }+          baseDep = Dependency "base" anyVersion mainLibSet++        updateContextAndWriteProjectFile' ctx sourcePackage+      ScriptContext scriptPath scriptExecutable -> do+        unless (length targetStrings == 1) $+          die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings+        existsScriptPath <- doesFileExist scriptPath+        unless existsScriptPath $+          die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings++        updateContextAndWriteProjectFile ctx scriptPath scriptExecutable+     (originalComponent, baseCtx') <- if null (envPackages envFlags)       then return (Nothing, baseCtx)       else@@ -237,7 +249,7 @@     -- In addition, to avoid a *third* trip through the solver, we are     -- replicating the second half of 'runProjectPreBuildPhase' by hand     -- here.-    (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $+    (buildCtx, compiler, replOpts') <- withInstallPlan verbosity baseCtx' $       \elaboratedPlan elaboratedShared' -> do         let ProjectBaseContext{..} = baseCtx' @@ -269,35 +281,23 @@            ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' -          -- First version of GHC where GHCi supported the flag we need.-          -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html-          minGhciScriptVersion = mkVersion [7, 6]--          replFlags' = case originalComponent of+          replFlags = case originalComponent of             Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci             Nothing  -> []-          replFlags'' = case replType of-            GlobalRepl scriptPath-              | Just version <- compilerCompatVersion GHC compiler-              , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags'-            _                                   -> replFlags' -        return (buildCtx, replFlags'')+        return (buildCtx, compiler, replOpts & lReplOptionsFlags %~ (++ replFlags)) -    let buildCtx' = buildCtx-          { elaboratedShared = (elaboratedShared buildCtx)-                { pkgConfigReplOptions = replFlags ++ replFlags'' }-          }+    replOpts'' <- case targetCtx of+      ProjectContext -> return replOpts'+      _              -> usingGhciScript compiler projectRoot replOpts'++    let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''     printPlan verbosity baseCtx' buildCtx'      buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx'     runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes-    finalizer   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)      validatedTargets elaboratedPlan targetSelectors = do       -- Interpret the targets on the command line as repl targets@@ -325,78 +325,6 @@   }   deriving (Show) --- | Tracks what type of GHCi instance we're creating.-data ReplType = ProjectRepl-              | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi-                                    --   script responsible for changing to the-                                    --   correct directory. Only works on GHC geq-                                    --   7.6, though. 🙁-              deriving (Show, Eq)--withProject :: ProjectConfig -> Verbosity -> [String]-            -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)-withProject cliConfig verbosity targetStrings = do-  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--  targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                 =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings--  return (baseCtx, targetSelectors, return (), ProjectRepl)--withoutProject :: ProjectConfig -> Verbosity -> [String]-               -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)-withoutProject config verbosity extraArgs = do-  unless (null extraArgs) $-    die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs--  globalTmp <- getTemporaryDirectory-  tempDir <- createTempDirectory globalTmp "cabal-repl."--  -- We need to create a dummy package that lives in our dummy project.-  let-    sourcePackage = SourcePackage-      { srcpkgPackageId     = pkgId-      , srcpkgDescription   = genericPackageDescription-      , srcpkgSource        = LocalUnpackedPackage tempDir-      , srcpkgDescrOverride = Nothing-      }-    genericPackageDescription = emptyGenericPackageDescription-      & L.packageDescription .~ packageDescription-      & L.condLibrary        .~ Just (CondNode library [baseDep] [])-    packageDescription = emptyPackageDescription-      { package = pkgId-      , specVersion = CabalSpecV2_2-      , licenseRaw = Left SPDX.NONE-      }-    library = emptyLibrary { libBuildInfo = buildInfo }-    buildInfo = emptyBuildInfo-      { targetBuildDepends = [baseDep]-      , defaultLanguage = Just Haskell2010-      }-    baseDep = Dependency "base" anyVersion mainLibSet-    pkgId = fakePackageId--  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription--  let ghciScriptPath = tempDir </> "setcwd.ghci"-  cwd <- getCurrentDirectory-  writeFile ghciScriptPath (":cd " ++ cwd)--  distDirLayout <- establishDummyDistDirLayout verbosity config tempDir-  baseCtx <--    establishDummyProjectBaseContext-      verbosity-      config-      distDirLayout-      [SpecificSourcePackage sourcePackage]-      OtherCommand--  let-    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]-    finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir)--  return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath)- addDepsToProjectTarget :: [Dependency]                        -> PackageId                        -> ProjectBaseContext@@ -415,7 +343,7 @@         }     addDeps spec = spec -generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags+generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags   where     exeDeps :: [UnitId]@@ -425,7 +353,7 @@         (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])      deps, deps', trans, trans' :: [UnitId]-    flags :: ReplFlags+    flags :: [String]     deps   = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId     deps'  = deps \\ ociOriginalDeps     trans  = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'@@ -433,6 +361,28 @@     flags  = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps)       $ if includeTransitive then trans' else deps' +-- | Add repl options to ensure the repl actually starts in the current working directory.+--+-- In a global or script context, when we are using a fake package, @cabal repl@+-- starts in the fake package directory instead of the directory it was called from,+-- so we need to tell ghci to change back to the correct directory.+--+-- The @-ghci-script@ flag is path to the ghci script responsible for changing to the+-- correct directory. Only works on GHC >= 7.6, though. 🙁+usingGhciScript :: Compiler -> FilePath -> ReplOptions -> IO ReplOptions+usingGhciScript compiler projectRoot replOpts+  | compilerCompatVersion GHC compiler >= Just minGhciScriptVersion = do+      let ghciScriptPath = projectRoot </> "setcwd.ghci"+      cwd <- getCurrentDirectory+      writeFile ghciScriptPath (":cd " ++ cwd)+      return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)+  | otherwise = return replOpts++-- | First version of GHC where GHCi supported the flag we need.+-- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html+minGhciScriptVersion :: Version+minGhciScriptVersion = mkVersion [7, 6]+ -- | 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.@@ -571,7 +521,7 @@     "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 @@ -580,3 +530,16 @@     "The reason for this limitation is that current versions of ghci do not "  ++ "support loading multiple components as source. Load just one component "  ++ "and when you make changes to a dependent component then quit and reload."++-- Lenses+lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig+lElaboratedShared f s = fmap (\x -> s { elaboratedShared = x }) (f (elaboratedShared s))+{-# inline lElaboratedShared #-}++lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions+lPkgConfigReplOptions f s = fmap (\x -> s { pkgConfigReplOptions = x }) (f (pkgConfigReplOptions s))+{-# inline lPkgConfigReplOptions #-}++lReplOptionsFlags :: Lens' ReplOptions [String]+lReplOptionsFlags f s = fmap (\x -> s { replOptionsFlags = x }) (f (replOptionsFlags s))+{-# inline lReplOptionsFlags #-}
src/Distribution/Client/CmdRun.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}  -- | cabal-install CLI command: run --@@ -42,24 +43,15 @@          ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName          ( showComponentName )-import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Verbosity-         ( normal )+         ( normal, silent ) import Distribution.Simple.Utils-         ( wrapText, warn, die', ordNub, info, notice-         , createTempDirectory, handleDoesNotExist )-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), ProjectConfigShared(..)-         , withProjectOrGlobalConfig )-import Distribution.Client.ProjectFlags-         ( flagIgnoreProject )+         ( wrapText, die', info, notice ) import Distribution.Client.ProjectPlanning          ( ElaboratedConfiguredPackage(..)          , ElaboratedInstallPlan, binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types          ( dataDirsEnvironmentForPlan )-import Distribution.Client.TargetSelector-         ( TargetSelectorProblem(..), TargetString(..) ) import Distribution.Client.InstallPlan          ( toList, foldPlanPackage ) import Distribution.Types.UnqualComponentName@@ -69,46 +61,14 @@            emptyProgramInvocation ) import Distribution.Types.UnitId          ( UnitId )--import Distribution.Client.Types-         ( PackageLocation(..), PackageSpecifier(..) )-import Distribution.FieldGrammar-         ( takeFields, parseFieldGrammar )-import Distribution.PackageDescription.FieldGrammar-         ( executableFieldGrammar )-import Distribution.PackageDescription.PrettyPrint-         ( writeGenericPackageDescription )-import Distribution.Parsec-         ( Position(..) )-import Distribution.Fields-         ( ParseResult, parseString, parseFatalFailure, readFields )-import qualified Distribution.SPDX.License as SPDX-import Distribution.Solver.Types.SourcePackage as SP-         ( SourcePackage(..) )-import Distribution.Types.BuildInfo-         ( BuildInfo(..) )-import Distribution.Types.CondTree-         ( CondTree(..) )-import Distribution.Types.Executable-         ( Executable(..) )-import Distribution.Types.GenericPackageDescription as GPD-         ( GenericPackageDescription(..), emptyGenericPackageDescription )-import Distribution.Types.PackageDescription-         ( PackageDescription(..), emptyPackageDescription )-import Distribution.Types.PackageName.Magic-         ( fakePackageId )-import Language.Haskell.Extension-         ( Language(..) )+import Distribution.Client.ScriptUtils+         ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) -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-         ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist )+         ( doesFileExist ) import System.FilePath-         ( (</>), isValid, isPathSeparator, takeExtension )-+         ( (</>), isValid, isPathSeparator )  runCommand :: CommandUI (NixStyleFlags ()) runCommand = CommandUI@@ -122,8 +82,9 @@        ++ "Any executable-like component in any package in the project can be "       ++ "specified. A package can be specified if contains just one "-      ++ "executable-like. The default is to use the package in the current "-      ++ "directory if it contains just one executable-like.\n\n"+      ++ "executable-like, preferring a single executable. The default is to "+      ++ "use the package in the current directory if it contains just one "+      ++ "executable-like.\n\n"        ++ "Extra arguments can be passed to the program, but use '--' to "       ++ "separate arguments for the program from arguments for " ++ pname@@ -158,44 +119,19 @@ -- "Distribution.Client.ProjectOrchestration" -- runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-runAction flags@NixStyleFlags {..} targetStrings globalFlags = do-    globalTmp <- getTemporaryDirectory-    tmpDir <- createTempDirectory globalTmp "cabal-repl."--    let-      with =-        establishProjectBaseContext verbosity cliConfig OtherCommand-      without config = do-        distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir-        establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand--    baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without--    let-      scriptOrError script err = do-        exists <- doesFileExist script-        let pol | takeExtension script == ".lhs" = LiterateHaskell-                | otherwise                      = PlainHaskell-        if exists-          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir-          else reportTargetSelectorProblems verbosity err+runAction flags@NixStyleFlags {..} targetAndArgs globalFlags+  = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags $ \targetCtx ctx targetSelectors -> do+    (baseCtx, defaultVerbosity) <- case targetCtx of+      ProjectContext             -> return (ctx, normal)+      GlobalContext              -> return (ctx, normal)+      ScriptContext path exemeta -> (, silent) <$> updateContextAndWriteProjectFile ctx path exemeta -    (baseCtx', targetSelectors) <--      readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings)-        >>= \case-          Left err@(TargetSelectorNoTargetsInProject:_)-            | (script:_) <- targetStrings -> scriptOrError script err-          Left err@(TargetSelectorNoSuch t _:_)-            | TargetString1 script <- t   -> scriptOrError script err-          Left err@(TargetSelectorExpected t _ _:_)-            | TargetString1 script <- t   -> scriptOrError script err-          Left err   -> reportTargetSelectorProblems verbosity err-          Right sels -> return (baseCtx, sels)+    let verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)      buildCtx <--      runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -            when (buildSettingOnlyDeps (buildSettings baseCtx')) $+            when (buildSettingOnlyDeps (buildSettings baseCtx)) $               die' verbosity $                   "The run command does not support '--only-dependencies'. "                ++ "You may wish to use 'build --only-dependencies' and then "@@ -237,10 +173,10 @@                        ++ "phase has been reached. This is a bug.")         $ targetsMap buildCtx -    printPlan verbosity baseCtx' buildCtx+    printPlan verbosity baseCtx buildCtx -    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx-    runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes+    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes       let elaboratedPlan = elaboratedPlanToExecute buildCtx@@ -283,8 +219,7 @@                                   pkg                                   exeName                </> exeName-    let args = drop 1 targetStrings-        dryRun = buildSettingDryRun (buildSettings baseCtx)+    let dryRun = buildSettingDryRun (buildSettings baseCtx)               || buildSettingOnlyDownload (buildSettings baseCtx)      if dryRun@@ -299,13 +234,8 @@                                  (distDirLayout baseCtx)                                  elaboratedPlan            }--    handleDoesNotExist () (removeDirectoryRecursive tmpDir)   where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)+    (targetStr, args) = splitAt 1 targetAndArgs  -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was -- invoked as a script interpreter, i.e. via@@ -333,120 +263,6 @@ handleShebang script args =   runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags -parseScriptBlock :: BS.ByteString -> ParseResult Executable-parseScriptBlock str =-    case readFields str of-        Right fs -> do-            let (fields, _) = takeFields fs-            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")-        Left perr -> parseFatalFailure pos (show perr) where-            ppos = P.errorPos perr-            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)--readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable-readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"--readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString)-readScriptBlockFromScript verbosity pol str = do-    str' <- case extractScriptBlock pol str of-              Left e -> die' verbosity $ "Failed extracting script block: " ++ e-              Right x -> return x-    when (BS.all isSpace str') $ warn verbosity "Empty script block"-    (\x -> (x, noShebang)) <$> readScriptBlock verbosity str'-  where-    noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str---- | Extract the first encountered script metadata block started end--- terminated by the tokens------ * @{- cabal:@------ * @-}@------ appearing alone on lines (while tolerating trailing whitespace).--- These tokens are not part of the 'Right' result.------ In case of missing or unterminated blocks a 'Left'-error is--- returned.-extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString-extractScriptBlock _pol str = goPre (BS.lines str)-  where-    isStartMarker = (== startMarker) . stripTrailSpace-    isEndMarker   = (== endMarker) . stripTrailSpace--    stripTrailSpace = fst . BS.spanEnd isSpace--    -- before start marker-    goPre ls = case dropWhile (not . isStartMarker) ls of-                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"-                 (_:ls') -> goBody [] ls'--    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"-    goBody acc (l:ls)-      | isEndMarker l = Right $! BS.unlines $ reverse acc-      | otherwise     = goBody (l:acc) ls--    startMarker, endMarker :: BS.ByteString-    startMarker = fromString "{- cabal:"-    endMarker   = fromString "-}"--data PlainOrLiterate-    = PlainHaskell-    | LiterateHaskell--handleScriptCase-  :: Verbosity-  -> PlainOrLiterate-  -> ProjectBaseContext-  -> FilePath-  -> BS.ByteString-  -> IO (ProjectBaseContext, [TargetSelector])-handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do-  (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents--  -- We need to create a dummy package that lives in our dummy project.-  let-    mainName = case pol of-      PlainHaskell    -> "Main.hs"-      LiterateHaskell -> "Main.lhs"--    sourcePackage = SourcePackage-      { srcpkgPackageId      = pkgId-      , srcpkgDescription    = genericPackageDescription-      , srcpkgSource         = LocalUnpackedPackage tmpDir-      , srcpkgDescrOverride  = Nothing-      }-    genericPackageDescription  = emptyGenericPackageDescription-      { GPD.packageDescription = packageDescription-      , condExecutables        = [("script", CondNode executable' targetBuildDepends [])]-      }-    executable' = executable-      { modulePath = mainName-      , buildInfo = binfo-        { defaultLanguage =-          case defaultLanguage of-            just@(Just _) -> just-            Nothing       -> Just Haskell2010-        }-      }-    binfo@BuildInfo{..} = buildInfo executable-    packageDescription = emptyPackageDescription-      { package = pkgId-      , specVersion = CabalSpecV2_2-      , licenseRaw = Left SPDX.NONE-      }-    pkgId = fakePackageId--  writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription-  BS.writeFile (tmpDir </> mainName) contents'--  let-    baseCtx' = baseCtx-      { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] }-    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]--  return (baseCtx', targetSelectors)- singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) singleExeOrElse action targetsMap =   case Set.toList . distinctTargetComponents $ targetsMap@@ -481,17 +297,21 @@                      -> [AvailableTarget k] -> Either RunTargetProblem [k] selectPackageTargets targetSelector targets -    -- If there is exactly one buildable executable then we select that+  -- If there is a single executable component, select that. See #7403   | [target] <- targetsExesBuildable   = Right [target] -    -- but fail if there are multiple buildable executables.-  | not (null targetsExesBuildable)-  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')+  -- Otherwise, if there is a single executable-like component left, select that.+  | [target] <- targetsExeLikesBuildable+  = Right [target] +  -- but fail if there are multiple buildable executables.+  | not (null targetsExeLikesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')+     -- If there are executables but none are buildable then we report those-  | not (null targetsExes)-  = Left (TargetProblemNoneEnabled targetSelector targetsExes)+  | not (null targetsExeLikes')+  = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')      -- If there are no executables but some other targets then we report that   | not (null targets)@@ -501,16 +321,21 @@   | otherwise   = Left (TargetProblemNoTargets targetSelector)   where-    -- Targets that can be executed-    targetsExecutableLike =-      concatMap (\kind -> filterTargetsKind kind targets)-                [ExeKind, TestKind, BenchKind]-    (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike+    -- Targets that are precisely executables+    targetsExes = filterTargetsKind ExeKind targets+    targetsExesBuildable = selectBuildableTargets targetsExes -    targetsExes             = forgetTargetsDetail targetsExecutableLike+    -- Any target that could be executed+    targetsExeLikes = targetsExes+                   ++ filterTargetsKind TestKind targets+                   ++ filterTargetsKind BenchKind targets +    (targetsExeLikesBuildable,+     targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes +    targetsExeLikes'             = forgetTargetsDetail targetsExeLikes++ -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. --@@ -611,7 +436,7 @@ 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) =
src/Distribution/Client/CmdSdist.hs view
@@ -138,7 +138,7 @@  sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do-    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject+    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject      let localPkgs = localPackages baseCtx @@ -187,7 +187,6 @@     listSources    = fromFlagOrDefault False sdistListSources     nulSeparated   = fromFlagOrDefault False sdistNulSeparated     mOutputPath    = flagToMaybe sdistOutputPath-    ignoreProject  = flagIgnoreProject      prjConfig :: ProjectConfig     prjConfig = commandLineFlagsToProjectConfig
src/Distribution/Client/CmdTest.hs view
@@ -46,7 +46,7 @@ testCommand :: CommandUI (NixStyleFlags ()) testCommand = CommandUI   { commandName         = "v2-test"-  , commandSynopsis     = "Run test-suites"+  , commandSynopsis     = "Run test-suites."   , commandUsage        = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]   , commandDescription  = Just $ \_ -> wrapText $         "Runs the specified test-suites, first ensuring they are up to "
src/Distribution/Client/CmdUpdate.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase      #-} {-# LANGUAGE NamedFieldPuns  #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections   #-} {-# LANGUAGE ViewPatterns    #-} @@ -13,6 +14,7 @@   ) where  import Prelude ()+import Control.Exception import Distribution.Client.Compat.Prelude  import Distribution.Client.NixStyleOptions@@ -42,10 +44,9 @@ import Distribution.Simple.Flag          ( fromFlagOrDefault ) import Distribution.Simple.Utils-         ( die', notice, wrapText, writeFileAtomic, noticeNoWrap )+         ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, warn ) import Distribution.Verbosity          ( normal, lessVerbose )-import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils          ( updateRepoIndexCache, Index(..), writeIndexTimestamp@@ -63,6 +64,7 @@          ( CommandUI(..), usageAlternatives )  import qualified Hackage.Security.Client as Sec+import Distribution.Client.IndexUtils.Timestamp (nullTimestamp)  updateCommand :: CommandUI (NixStyleFlags ()) updateCommand = CommandUI@@ -201,7 +203,8 @@               then Just `fmap` getCurrentTime               else return Nothing       updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce-+      -- this resolves indexState (which could be HEAD) into a timestamp+      new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo       let rname = remoteRepoName (repoRemote repo)        -- Update cabal's internal index as well so that it's not out of sync@@ -209,22 +212,26 @@       case updated of         Sec.NoUpdates  -> do           now <- getCurrentTime-          setModificationTime (indexBaseName repo <.> "tar") now+          setModificationTime (indexBaseName repo <.> "tar") now `catchIO`+             (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e)           noticeNoWrap verbosity $-            "Package list of " ++ prettyShow rname ++-            " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts)+            "Package list of " ++ prettyShow rname ++ " is up to date."          Sec.HasUpdates -> do           updateRepoIndexCache verbosity index-          new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo           noticeNoWrap verbosity $-            "Updated package list of " ++ prettyShow rname ++-            " to the index-state " ++ prettyShow (IndexStateTime new_ts)+            "Package list of " ++ prettyShow rname ++ " has been updated." -          -- TODO: This will print multiple times if there are multiple-          -- repositories: main problem is we don't have a way of updating-          -- a specific repo.  Once we implement that, update this.-          when (current_ts /= nullTimestamp) $-            noticeNoWrap verbosity $-              "To revert to previous state run:\n" ++-              "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"+      noticeNoWrap verbosity $+        "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "."++      -- TODO: This will print multiple times if there are multiple+      -- repositories: main problem is we don't have a way of updating+      -- a specific repo.  Once we implement that, update this.++      -- In case current_ts is a valid timestamp different from new_ts, let+      -- the user know how to go back to current_ts+      when (current_ts /= nullTimestamp && new_ts /= current_ts) $+        noticeNoWrap verbosity $+          "To revert to previous state run:\n" +++          "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
− src/Distribution/Client/Compat/FilePerms.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Distribution.Client.Compat.FilePerms (-  setFileOrdinary,-  setFileExecutable,-  setFileHidden,-  ) where--import Prelude (FilePath, IO, return, ($))--#ifndef mingw32_HOST_OS-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-import Foreign.C-         ( withCString-         , throwErrnoPathIfMinus1_ )-#else-import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN)-#endif /* mingw32_HOST_OS */--setFileHidden, setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()-#ifndef mingw32_HOST_OS-setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r---setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x-setFileHidden     _    = return ()--setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-  withCString name $ \s ->-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#else-setFileOrdinary   _ = return ()-setFileExecutable _ = return ()-setFileHidden  path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN-#endif
src/Distribution/Client/Compat/Semaphore.hs view
@@ -17,7 +17,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE --- | 'QSem' is a quantity semaphore in which the resource is aqcuired+-- | 'QSem' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSem` calls. --
src/Distribution/Client/Config.hs view
@@ -112,7 +112,7 @@          ( defaultProgramDb ) import Distribution.Simple.Utils          ( die', notice, warn, lowercase, cabalVersion, toUTF8BS )-import Distribution.Client.Utils+import Distribution.Client.Version          ( cabalInstallVersion ) import Distribution.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor )@@ -243,7 +243,6 @@         globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,         globalActiveRepos       = combine globalActiveRepos,         globalLogsDir           = combine globalLogsDir,-        globalWorldFile         = combine globalWorldFile,         globalIgnoreExpiry      = combine globalIgnoreExpiry,         globalHttpTransport     = combine globalHttpTransport,         globalNix               = combine globalNix,@@ -264,6 +263,7 @@         IT.email               = combine IT.email,         IT.exposedModules      = combineMonoid savedInitFlags IT.exposedModules,         IT.extraSrc            = combineMonoid savedInitFlags IT.extraSrc,+        IT.extraDoc            = combineMonoid savedInitFlags IT.extraDoc,         IT.homepage            = combine IT.homepage,         IT.initHcPath          = combine IT.initHcPath,         IT.initVerbosity       = combine IT.initVerbosity,@@ -320,7 +320,6 @@         installReportPlanningFailure = combine installReportPlanningFailure,         installSymlinkBinDir         = combine installSymlinkBinDir,         installPerComponent          = combine installPerComponent,-        installOneShot               = combine installOneShot,         installNumJobs               = combine installNumJobs,         installKeepGoing             = combine installKeepGoing,         installRunTests              = combine installRunTests,@@ -375,6 +374,7 @@         configScratchDir          = combine configScratchDir,         -- TODO: NubListify         configExtraLibDirs        = lastNonEmpty configExtraLibDirs,+        configExtraLibDirsStatic  = lastNonEmpty configExtraLibDirsStatic,         -- TODO: NubListify         configExtraFrameworkDirs  = lastNonEmpty configExtraFrameworkDirs,         -- TODO: NubListify@@ -407,6 +407,7 @@         configFlagError           = combine configFlagError,         configRelocatable         = combine configRelocatable,         configUseResponseFiles    = combine configUseResponseFiles,+        configDumpBuildInfo       = combine configDumpBuildInfo,         configAllowDependingOnPrivateLibs =             combine configAllowDependingOnPrivateLibs         }@@ -418,6 +419,8 @@        combinedSavedConfigureExFlags = ConfigExFlags {         configCabalVersion  = combine configCabalVersion,+        configAppend        = combine configAppend,+        configBackup        = combine configBackup,         -- TODO: NubListify         configExConstraints = lastNonEmpty configExConstraints,         -- TODO: NubListify@@ -535,7 +538,6 @@   userPrefix <- getCabalDir   cacheDir   <- defaultCacheDir   logsDir    <- defaultLogsDir-  worldFile  <- defaultWorldFile   return mempty {     savedConfigureFlags  = mempty {       configHcFlavor     = toFlag defaultCompiler,@@ -547,8 +549,7 @@     },     savedGlobalFlags = mempty {       globalCacheDir     = toFlag cacheDir,-      globalLogsDir      = toFlag logsDir,-      globalWorldFile    = toFlag worldFile+      globalLogsDir      = toFlag logsDir     }   } @@ -562,14 +563,12 @@ initialSavedConfig = do   cacheDir    <- defaultCacheDir   logsDir     <- defaultLogsDir-  worldFile   <- defaultWorldFile   extraPath   <- defaultExtraPath   installPath <- defaultInstallPath   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = toNubList [defaultRemoteRepo],-      globalWorldFile    = toFlag worldFile+      globalRemoteRepos  = toNubList [defaultRemoteRepo]     },     savedConfigureFlags  = mempty {       configProgramPathExtra = toNubList extraPath@@ -609,12 +608,6 @@   dir <- getCabalDir   return $ dir </> "logs" --- | Default position of the world file-defaultWorldFile :: IO FilePath-defaultWorldFile = do-  dir <- getCabalDir-  return $ dir </> "world"- defaultExtraPath :: IO [FilePath] defaultExtraPath = do   dir <- getCabalDir@@ -738,8 +731,21 @@     Nothing -> do       notice verbosity $         "Config file path source is " ++ sourceMsg source ++ "."-      notice verbosity $ "Config file " ++ configFile ++ " not found."-      createDefaultConfigFile verbosity [] configFile+      -- 2021-10-07, issue #7705+      -- Only create default config file if name was not given explicitly+      -- via option --config-file or environment variable.+      case source of+        Default -> do+          notice verbosity msgNotFound+          createDefaultConfigFile verbosity [] configFile+        CommandlineOption   -> failNoConfigFile+        EnvironmentVariable -> failNoConfigFile+      where+        msgNotFound = unwords [ "Config file not found:", configFile ]+        failNoConfigFile = die' verbosity $ unlines+          [ msgNotFound+          , "(Config files can be created via the cabal-command 'user-config init'.)"+          ]     Just (ParseOk ws conf) -> do       unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)@@ -752,9 +758,11 @@    where     sourceMsg CommandlineOption =   "commandline option"-    sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"+    sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG"     sourceMsg Default =             "default config file" +-- | Provenance of the config file.+ data ConfigFileSource = CommandlineOption                       | EnvironmentVariable                       | Default@@ -841,8 +849,8 @@             IT.cabalVersion    = toFlag IT.defaultCabalVersion,             IT.language        = toFlag Haskell2010,             IT.license         = NoFlag,-            IT.sourceDirs      = Just [IT.defaultSourceDir],-            IT.applicationDirs = Just [IT.defaultApplicationDir]+            IT.sourceDirs      = Flag [IT.defaultSourceDir],+            IT.applicationDirs = Flag [IT.defaultApplicationDir]             },         savedInstallFlags      = defaultInstallFlags,         savedClientInstallFlags= defaultClientInstallFlags,@@ -1174,6 +1182,8 @@                        (fromNubList $ configProgramPathExtra scf)                    , configExtraLibDirs       = splitMultiPath                                                 (configExtraLibDirs scf)+                   , configExtraLibDirsStatic = splitMultiPath+                                                (configExtraLibDirsStatic scf)                    , configExtraFrameworkDirs = splitMultiPath                                                 (configExtraFrameworkDirs scf)                    , configExtraIncludeDirs   = splitMultiPath
src/Distribution/Client/Configure.hs view
@@ -59,7 +59,9 @@ import Distribution.Simple.Setup          ( ConfigFlags(..)          , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.PackageIndex+import Distribution.Simple.PackageDescription+         ( readGenericPackageDescription )+import Distribution.Simple.PackageIndex as PackageIndex          ( InstalledPackageIndex, lookupPackageName ) import Distribution.Package          ( Package(..), packageName, PackageId )@@ -68,8 +70,6 @@ import Distribution.Types.PackageVersionConstraint          ( PackageVersionConstraint(..), thisPackageVersionConstraint ) import qualified Distribution.PackageDescription as PkgDesc-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription ) import Distribution.PackageDescription.Configuration          ( finalizePD ) import Distribution.Version@@ -279,7 +279,7 @@                          configExConstraints flags     unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $                          configPreferences flags-    unknown pkg = null (lookupPackageName installedPkgIndex pkg)+    unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg)                && not (elemByPackageName sourcePkgIndex pkg)     showConstraint (uc, src) =         prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"@@ -311,10 +311,13 @@         srcpkgDescrOverride      = Nothing       } +      testsEnabled :: Bool       testsEnabled = fromFlagOrDefault False $ configTests configFlags+      benchmarksEnabled :: Bool       benchmarksEnabled =         fromFlagOrDefault False $ configBenchmarks configFlags +      resolverParams :: DepResolverParams       resolverParams =           removeLowerBounds           (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)@@ -392,7 +395,9 @@     scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)    where+    gpkg :: PkgDesc.GenericPackageDescription     gpkg = srcpkgDescription spkg+    configureFlags :: Version -> ConfigFlags     configureFlags   = filterConfigureFlags configFlags {       configIPID = if isJust (flagToMaybe (configIPID configFlags))                     -- Make sure cabal configure --ipid works.@@ -420,6 +425,7 @@                                     `mappend` configTests configFlags     } +    pkg :: PkgDesc.PackageDescription     pkg = case finalizePD flags (enableStanzas stanzas)            (const True)            platform comp [] gpkg of
src/Distribution/Client/Dependency.hs view
@@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module Distribution.Client.Dependency (     -- * The main package dependency resolver+    DepResolverParams,     chooseSolver,     resolveDependencies,     Progress(..),@@ -464,6 +465,7 @@       depResolverSourcePkgIndex = sourcePkgIndex'     }   where+    sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage     sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params      relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage@@ -735,6 +737,7 @@         then params         else dontUpgradeNonUpgradeablePackages params +    preferences :: PackageName -> PackagePreferences     preferences = interpretPackagesPreference targets defpref prefs  @@ -750,12 +753,14 @@                                  (installPref pkgname)                                  (stanzasPref pkgname)   where+    versionPref :: PackageName -> [VersionRange]     versionPref pkgname =       fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)     versionPrefs = Map.fromListWith (++)                    [(pkgname, [pref])                    | PackageVersionPreference pkgname pref <- prefs] +    installPref :: PackageName -> InstalledPreference     installPref pkgname =       fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)     installPrefs = Map.fromList@@ -770,6 +775,7 @@         if pkgname `Set.member` selected then PreferLatest                                          else PreferInstalled +    stanzasPref :: PackageName -> [OptionalStanza]     stanzasPref pkgname =       fromMaybe [] (Map.lookup pkgname stanzasPrefs)     stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))@@ -797,9 +803,12 @@       problems               -> error (formatPkgProblems problems)    where+    graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)     graph = Graph.fromDistinctList pkgs +    formatPkgProblems :: [PlanPackageProblem] -> String     formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem+    formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String     formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem      formatProblemMessage problems =@@ -894,6 +903,7 @@                             , not (packageSatisfiesDependency pkgid dep) ]   -- TODO: sanity tests on executable deps   where+    thisPkgName :: PackageName     thisPkgName = packageName (srcpkgDescription pkg)      specifiedDeps1 :: ComponentDeps [PackageId]@@ -902,10 +912,12 @@     specifiedDeps :: [PackageId]     specifiedDeps = CD.flatDeps specifiedDeps1 +    mergedFlags :: [MergeResult PD.FlagName PD.FlagName]     mergedFlags = mergeBy compare       (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))       (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO +    packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool     packageSatisfiesDependency       (PackageIdentifier name  version)       (Dependency        name' versionRange _) = assert (name == name') $@@ -991,7 +1003,9 @@        where         -- Constraints+        requiredVersions :: VersionRange         requiredVersions = packageConstraints pkgname+        choices          :: [UnresolvedSourcePackage]         choices          = PackageIndex.lookupDependency sourcePkgIndex                                                          pkgname                                                          requiredVersions@@ -1000,20 +1014,24 @@         PackagePreferences preferredVersions preferInstalled _           = packagePreferences pkgname +        bestByPrefs   :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering         bestByPrefs   = comparing $ \pkg ->                           (installPref pkg, versionPref pkg, packageVersion pkg)+        installPref   :: UnresolvedSourcePackage -> Bool         installPref   = case preferInstalled of           PreferLatest    -> const False           PreferInstalled -> not . null                            . InstalledPackageIndex.lookupSourcePackageId                                                      installedPkgIndex                            . packageId+        versionPref     :: Package a => a -> Int         versionPref pkg = length . filter (packageVersion pkg `withinRange`) $                           preferredVersions      packageConstraints :: PackageName -> VersionRange     packageConstraints pkgname =       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap+    packageVersionConstraintMap :: Map PackageName VersionRange     packageVersionConstraintMap =       let pcs = map unlabelPackageConstraint constraints       in Map.fromList [ (scopeToPackageName scope, range)
src/Distribution/Client/DistDirLayout.hs view
@@ -28,7 +28,7 @@ import System.FilePath  import Distribution.Package-         ( PackageId, ComponentId, UnitId )+         ( PackageId, PackageIdentifier, ComponentId, UnitId ) import Distribution.Compiler import Distribution.Simple.Compiler          ( PackageDB(..), PackageDBStack, OptimisationLevel(..) )@@ -147,8 +147,7 @@ data CabalDirLayout = CabalDirLayout {        cabalStoreDirLayout        :: StoreDirLayout, -       cabalLogsDirectory         :: FilePath,-       cabalWorldFile             :: FilePath+       cabalLogsDirectory         :: FilePath      }  @@ -182,14 +181,21 @@       ProjectRootImplicit dir      -> (dir, dir </> "cabal.project")       ProjectRootExplicit dir file -> (dir, dir </> file) +    distProjectRootDirectory :: FilePath     distProjectRootDirectory = projectRootDir++    distProjectFile :: String -> FilePath     distProjectFile ext      = projectFile <.> ext +    distDirectory :: FilePath     distDirectory = distProjectRootDirectory                 </> fromMaybe "dist-newstyle" mdistDirectory     --TODO: switch to just dist at some point, or some other new name +    distBuildRootDirectory :: FilePath     distBuildRootDirectory   = distDirectory </> "build"++    distBuildDirectory :: DistDirParams -> FilePath     distBuildDirectory params =         distBuildRootDirectory </>         prettyShow (distParamPlatform params) </>@@ -212,27 +218,44 @@                 then ""                 else uid_str) +    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 +    distProjectCacheDirectory :: FilePath     distProjectCacheDirectory = distDirectory </> "cache"++    distProjectCacheFile :: FilePath -> FilePath     distProjectCacheFile name = distProjectCacheDirectory </> name +    distPackageCacheDirectory :: DistDirParams -> FilePath     distPackageCacheDirectory params = distBuildDirectory params </> "cache"++    distPackageCacheFile :: DistDirParams -> String -> FilePath     distPackageCacheFile params name = distPackageCacheDirectory params </> name +    distSdistFile :: PackageIdentifier -> FilePath     distSdistFile pid = distSdistDirectory </> prettyShow pid <.> "tar.gz" +    distSdistDirectory :: FilePath     distSdistDirectory = distDirectory </> "sdist" +    distTempDirectory :: FilePath     distTempDirectory = distDirectory </> "tmp" +    distBinDirectory :: FilePath     distBinDirectory = distDirectory </> "bin" +    distPackageDBPath :: CompilerId -> FilePath     distPackageDBPath compid = distDirectory </> "packagedb" </> prettyShow compid++    distPackageDB :: CompilerId -> PackageDB     distPackageDB = SpecificPackageDB . distPackageDBPath  @@ -240,24 +263,31 @@ defaultStoreDirLayout storeRoot =     StoreDirLayout {..}   where+    storeDirectory :: CompilerId -> FilePath     storeDirectory compid =       storeRoot </> prettyShow compid +    storePackageDirectory :: CompilerId -> UnitId -> FilePath     storePackageDirectory compid ipkgid =       storeDirectory compid </> prettyShow ipkgid +    storePackageDBPath :: CompilerId -> FilePath     storePackageDBPath compid =       storeDirectory compid </> "package.db" +    storePackageDB :: CompilerId -> PackageDB     storePackageDB compid =       SpecificPackageDB (storePackageDBPath compid) +    storePackageDBStack :: CompilerId -> PackageDBStack     storePackageDBStack compid =       [GlobalPackageDB, storePackageDB compid] +    storeIncomingDirectory :: CompilerId -> FilePath     storeIncomingDirectory compid =       storeDirectory compid </> "incoming" +    storeIncomingLock :: CompilerId -> UnitId -> FilePath     storeIncomingLock compid unitid =       storeIncomingDirectory compid </> prettyShow unitid <.> "lock" @@ -273,7 +303,8 @@ mkCabalDirLayout cabalDir mstoreDir mlogDir =     CabalDirLayout {..}   where+    cabalStoreDirLayout :: StoreDirLayout     cabalStoreDirLayout =         defaultStoreDirLayout (fromMaybe (cabalDir </> "store") mstoreDir)+    cabalLogsDirectory :: FilePath     cabalLogsDirectory = fromMaybe (cabalDir </> "logs") mlogDir-    cabalWorldFile = cabalDir </> "world"
src/Distribution/Client/Fetch.hs view
@@ -57,7 +57,7 @@ -- * support tarball URLs via ad-hoc download cache (or in -o mode?) -- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied -- * Port various flags from install:---   * --updage-dependencies+--   * --upgrade-dependencies --   * --constraint and --preference --   * --only-dependencies, but note it conflicts with --no-deps @@ -78,7 +78,7 @@     notice verbosity "No packages requested. Nothing to do."  fetch verbosity packageDBs repoCtxt comp platform progdb-      globalFlags fetchFlags userTargets = do+      _ fetchFlags userTargets = do      traverse_ (checkTarget verbosity) userTargets @@ -87,7 +87,6 @@     pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        userTargets @@ -147,6 +146,7 @@         resolveWithoutDependencies resolverParams    where+    resolverParams :: DepResolverParams     resolverParams =          setMaxBackjumps (if maxBackjumps < 0 then Nothing@@ -225,7 +225,7 @@      RemoteSourceRepoPackage _repo _ ->       die' verbosity $ "The 'fetch' command does not yet support remote "-         ++ "source repositores."+         ++ "source repositories."      RepoTarballPackage repo pkgid _ -> do       _ <- fetchRepoTarball verbosity repoCtxt repo pkgid
src/Distribution/Client/FetchUtils.hs view
@@ -52,7 +52,7 @@          ( ProgressPhase(..), progressMessage )  import qualified Data.Map as Map-import Control.Exception+import qualified Control.Exception.Safe as Safe import Control.Concurrent.Async import Control.Concurrent.MVar import System.Directory@@ -146,6 +146,7 @@     RemoteSourceRepoPackage _repo Nothing ->       die' verbosity "fetchPackage: source repos not supported"   where+    downloadTarballPackage :: URI -> IO FilePath     downloadTarballPackage uri = do       transport <- repoContextGetTransport repoCtxt       transportCheckHttps verbosity transport uri@@ -173,6 +174,7 @@     -- whether we download or not is non-deterministic     verbosity = verboseUnmarkOutput verbosity' +    downloadRepoPackage :: IO FilePath     downloadRepoPackage = case repo of       RepoLocalNoIndex{} -> return (packageFile repo pkgid) @@ -225,8 +227,11 @@ -- -- The body action is passed a map from those packages (identified by their -- location) to a completion var for that package. So the body action should--- lookup the location and use 'asyncFetchPackage' to get the result.+-- lookup the location and use 'waitAsyncFetchPackage' to get the result. --+-- Synchronous exceptions raised by the download actions are delivered+-- via 'waitAsyncFetchPackage'.+-- asyncFetchPackages :: Verbosity                    -> RepoContext                    -> [UnresolvedPkgLoc]@@ -245,13 +250,17 @@         fetchPackages =           for_ asyncDownloadVars $ \(pkgloc, var) -> do             -- Suppress marking here, because 'withAsync' means-            -- that we get nondeterministic interleaving-            result <- try $ fetchPackage (verboseUnmarkOutput verbosity)-                                repoCtxt pkgloc+            -- that we get nondeterministic interleaving.+            -- It is essential that we don't catch async exceptions here,+            -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.+            result <- Safe.try $+              fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc             putMVar var result -    withAsync fetchPackages $ \_ ->-      body (Map.fromList asyncDownloadVars)+    (_, res) <- concurrently+        fetchPackages+        (body $ Map.fromList asyncDownloadVars)+    pure res   -- | Expect to find a download in progress in the given 'AsyncFetchMap'
src/Distribution/Client/FileMonitor.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,              NamedFieldPuns, BangPatterns, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | An abstraction to help with re-running actions when files or other -- input values they depend on have changed.@@ -282,12 +283,13 @@ -- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =-    map getSinglePath singlePaths- ++ map getGlobPath globPaths+  map getSinglePath singlePaths ++ map getGlobPath globPaths   where+    getSinglePath :: MonitorStateFile -> MonitorFilePath     getSinglePath (MonitorStateFile kindfile kinddir filepath _) =       MonitorFile kindfile kinddir filepath +    getGlobPath :: MonitorStateGlob -> MonitorFilePath     getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =       MonitorFileGlob kindfile kinddir $ FilePathGlob root $         case gstate of@@ -418,7 +420,7 @@ -- See 'FileMonitor' for a full explanation. -- checkFileMonitorChanged-  :: (Binary a, Structured a, Binary b, Structured b)+  :: forall a b. (Binary a, Structured a, Binary b, Structured b)   => FileMonitor a b            -- ^ cache file path   -> FilePath                   -- ^ root directory   -> a                          -- ^ guard or key value@@ -439,6 +441,7 @@                checkStatusCache    where+    checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b)     checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do         change <- checkForChanges         case change of@@ -450,8 +453,9 @@       where         -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that         -- if we return MonitoredValueChanged that only the value changed.-        -- We do that by checkin for file changes first. Otherwise it makes+        -- We do that by checking for file changes first. Otherwise it makes         -- more sense to do the cheaper test first.+        checkForChanges :: IO (Maybe (MonitorChangedReason a))         checkForChanges           | fileMonitorCheckIfOnlyValueChanged           = checkFileChange cachedFileStatus cachedKey cachedResult@@ -463,7 +467,7 @@               `mplusMaybeT`             checkFileChange cachedFileStatus cachedKey cachedResult -    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1)     mplusMaybeT ma mb = do       mx <- ma       case mx of@@ -471,6 +475,7 @@         Just x  -> return (Just x)      -- Check if the guard value has changed+    checkValueChange :: a -> IO (Maybe (MonitorChangedReason a))     checkValueChange cachedKey       | not (fileMonitorKeyValid currentKey cachedKey)       = return (Just (MonitoredValueChanged cachedKey))@@ -478,6 +483,7 @@       = return Nothing      -- Check if any file has changed+    checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a))     checkFileChange cachedFileStatus cachedKey cachedResult = do       res <- probeFileSystem root cachedFileStatus       case res of@@ -762,7 +768,7 @@       return (MonitorStateGlobFiles glob mtime' children)-    -- Again, we don't force a cache rewite with 'cacheChanged', but we do use+    -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use     -- the new mtime' if any.   where     probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath@@ -1027,16 +1033,19 @@                     collectAllFileHashes singlePaths         `Map.union` collectAllGlobHashes globPaths +    collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash)     collectAllFileHashes singlePaths =       Map.fromList [ (fpath, (mtime, hash))                    | MonitorStateFile _ _ fpath                        (MonitorStateFileHashed mtime hash) <- singlePaths ] +    collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash)     collectAllGlobHashes globPaths =       Map.fromList [ (fpath, (mtime, hash))                    | MonitorStateGlob _ _ _ gstate <- globPaths                    , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] +    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))]     collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =       [ res       | (subdir, fstate) <- entries
src/Distribution/Client/Freeze.hs view
@@ -105,14 +105,13 @@               -> FreezeFlags               -> IO [SolverPlanPackage] getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb-      globalFlags freezeFlags = do+      _ freezeFlags = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt     pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        [UserTargetLocalDir "."] @@ -121,6 +120,7 @@                verbosity comp platform freezeFlags                installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers   where+    sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()     sanityCheck pkgSpecifiers = do       when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $         die' verbosity $ "internal error: 'resolveUserTargets' returned "@@ -154,6 +154,7 @@   return $ pruneInstallPlan installPlan pkgSpecifiers    where+    resolverParams :: DepResolverParams     resolverParams =          setMaxBackjumps (if maxBackjumps < 0 then Nothing
src/Distribution/Client/GenBounds.hs view
@@ -18,7 +18,7 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Client.Init+import Distribution.Client.Utils          ( incVersion ) import Distribution.Client.Freeze          ( getFreezePkgs )@@ -30,13 +30,13 @@          ( enabledBuildDepends ) import Distribution.PackageDescription.Configuration          ( finalizePD )-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription ) import Distribution.Types.ComponentRequestedSpec          ( defaultComponentRequestedSpec ) import Distribution.Types.Dependency import Distribution.Simple.Compiler          ( Compiler, PackageDBStack, compilerInfo )+import Distribution.Simple.PackageDescription+         ( readGenericPackageDescription ) import Distribution.Simple.Program          ( ProgramDb ) import Distribution.Simple.Utils@@ -93,7 +93,7 @@     -> GlobalFlags     -> FreezeFlags     -> IO ()-genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do +genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do     let cinfo = compilerInfo comp      cwd <- getCurrentDirectory
src/Distribution/Client/Get.hs view
@@ -67,7 +67,7 @@ get verbosity _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -get verbosity repoCtxt globalFlags getFlags userTargets = do+get verbosity repoCtxt _ getFlags userTargets = do   let useSourceRepo = case getSourceRepository getFlags of                         NoFlag -> False                         _      -> True@@ -84,7 +84,6 @@   (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                   (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)                    userTargets @@ -100,16 +99,19 @@     else unpack pkgs    where+    resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams     resolverParams sourcePkgDb pkgSpecifiers =         --TODO: add command-line constraint and preference args for unpack         standardInstallPolicy mempty sourcePkgDb pkgSpecifiers +    prefix :: String     prefix = fromFlagOrDefault "" (getDestDir getFlags)      clone :: [UnresolvedSourcePackage] -> IO ()     clone = clonePackagesFromSourceRepo verbosity prefix kind           . map (\pkg -> (packageId pkg, packageSourceRepos pkg))       where+        kind :: Maybe RepoKind         kind = fromFlag . getSourceRepository $ getFlags         packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]         packageSourceRepos = PD.sourceRepos@@ -140,6 +142,7 @@           LocalUnpackedPackage _ ->             error "Distribution.Client.Get.unpack: the impossible happened."       where+        usePristine :: Bool         usePristine = fromFlagOrDefault False (getPristine getFlags)  checkTarget :: Verbosity -> UserTarget -> IO ()@@ -291,7 +294,8 @@         Left SourceRepoLocationUnspecified ->           throwIO (ClonePackageNoRepoLocation pkgid repo) -      let destDir = destDirPrefix </> prettyShow (packageName pkgid)+      let destDir :: FilePath+          destDir = destDirPrefix </> prettyShow (packageName pkgid)       destDirExists  <- doesDirectoryExist destDir       destFileExists <- doesFileExist      destDir       when (destDirExists || destFileExists) $
src/Distribution/Client/GlobalFlags.hs view
@@ -65,7 +65,6 @@     , globalLocalNoIndexRepos :: NubList LocalRepo     , globalActiveRepos       :: Flag ActiveRepos     , globalLogsDir           :: Flag FilePath-    , globalWorldFile         :: Flag FilePath     , globalIgnoreExpiry      :: Flag Bool    -- ^ Ignore security expiry dates     , globalHttpTransport     :: Flag String     , globalNix               :: Flag Bool  -- ^ Integrate with Nix@@ -84,7 +83,6 @@     , globalLocalNoIndexRepos = mempty     , globalActiveRepos       = mempty     , globalLogsDir           = mempty-    , globalWorldFile         = mempty     , globalIgnoreExpiry      = Flag False     , globalHttpTransport     = mempty     , globalNix               = Flag False@@ -114,7 +112,7 @@     --     -- NOTE: It is important that we don't eagerly initialize the transport.     -- Initializing the transport is not free, and especially in contexts where-    -- we don't know a-priori whether or not we need the transport (for instance+    -- we don't know a priori whether or not we need the transport (for instance     -- when using cabal in "nix mode") incurring the overhead of transport     -- initialization on _every_ invocation (eg @cabal build@) is undesirable.   , repoContextGetTransport :: IO HttpTransport
src/Distribution/Client/Haddock.hs view
@@ -64,6 +64,7 @@    where     (destDir,destFile) = splitFileName index+    pkgs' :: [InstalledPackageInfo]     pkgs' = [ maximumBy (comparing packageVersion) pkgvers'             | (_pname, pkgvers) <- allPackagesByName pkgs             , let pkgvers' = filter exposed pkgvers
src/Distribution/Client/HashValue.hs view
@@ -64,7 +64,7 @@  -- | Convert a hash from TUF metadata into a 'PackageSourceHash'. ----- Note that TUF hashes don't neessarily have to be SHA256, since it can+-- Note that TUF hashes don't necessarily have to be SHA256, since it can -- support new algorithms in future. -- hashFromTUF :: Sec.Hash -> HashValue
src/Distribution/Client/HttpUtils.hs view
@@ -32,8 +32,11 @@ import Distribution.Simple.Utils          ( die', info, warn, debug, notice          , copyFileVerbose,  withTempFile, IOData (..) )+import Distribution.Utils.String (trim) import Distribution.Client.Utils-         ( withTempFileName, cabalInstallVersion )+         ( withTempFileName )+import Distribution.Client.Version+         ( cabalInstallVersion ) import Distribution.Client.Types          ( unRepoName, RemoteRepo(..) ) import Distribution.System@@ -143,6 +146,7 @@       NeedsDownload hash -> makeDownload transport' hash Nothing    where+    makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult     makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do       result <- getHttp transport' verbosity uri etag tmpFile [] @@ -395,8 +399,9 @@                    [ ["--header", show name ++ ": " ++ value]                    | Header name value <- reqHeaders ] -          resp <- getProgramInvocationOutput verbosity+          resp <- getProgramInvocationOutput verbosity $ addAuthConfig Nothing uri                     (programInvocation prog args)+           withFile tmpFile ReadMode $ \hnd -> do             headers <- hGetContents hnd             (code, _err, etag') <- parseResponse verbosity uri resp headers@@ -404,15 +409,26 @@      posthttp = noPostYet -    addAuthConfig auth progInvocation = progInvocation-      { progInvokeInput = do-          (uname, passwd) <- auth-          return $ IODataText $ unlines-            [ "--digest"-            , "--user " ++ uname ++ ":" ++ passwd-            ]-      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation-      }+    addAuthConfig explicitAuth uri progInvocation = do+      -- attempt to derive a u/p pair from the uri authority if one exists+      -- all `uriUserInfo` values have '@' as a suffix. drop it.+      let uriDerivedAuth = case uriAuthority uri of+                               (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u+                               _ -> Nothing+      -- prefer passed in auth to auth derived from uri. If neither exist, then no auth+      let mbAuthString = case (explicitAuth, uriDerivedAuth) of+                          (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd)+                          (Nothing, Just a) -> Just a+                          (Nothing, Nothing) -> Nothing+      case mbAuthString of+        Just up -> progInvocation+          { progInvokeInput = Just . IODataText . unlines $+              [ "--digest"+              , "--user " ++ up+              ]+          , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation+          }+        Nothing -> progInvocation      posthttpfile verbosity uri path auth = do         let args = [ show uri@@ -423,7 +439,7 @@                    , "--header", "Accept: text/plain"                    , "--location"                    ]-        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri                   (programInvocation prog args)         (code, err, _etag) <- parseResponse verbosity uri resp ""         return (code, err)@@ -440,7 +456,7 @@                 ++ concat                    [ ["--header", show name ++ ": " ++ value]                    | Header name value <- headers ]-        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri                   (programInvocation prog args)         (code, err, _etag) <- parseResponse verbosity uri resp ""         return (code, err)@@ -479,7 +495,7 @@          -- wget doesn't support range requests.         -- so, we not only ignore range request headers,-        -- but we also dispay a warning message when we see them.+        -- but we also display a warning message when we see them.         let hasRangeHeader =  any isRangeHeader reqHeaders             warningMsg     =  "the 'wget' transport currently doesn't support"                            ++ " range requests, which wastes network bandwidth."@@ -874,12 +890,6 @@ statusParseFail verbosity uri r =     die' verbosity $ "Failed to download " ++ show uri ++ " : "        ++ "No Status Code could be parsed from response: " ++ r---- Trim-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace-  ------------------------------------------------------------------------------ -- Multipart stuff partially taken from cgi package.
src/Distribution/Client/IndexUtils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-}@@ -40,7 +41,10 @@   writeIndexTimestamp,   currentIndexTimestamp, -  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType+  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType,+  -- * preferred-versions utilities+  preferredVersions, isPreferredVersions, parsePreferredVersionsWarnings,+  PreferredVersionsParseError(..)   ) where  import Prelude ()@@ -75,24 +79,26 @@ import Distribution.Version          ( Version, VersionRange, mkVersion, intersectVersionRanges ) import Distribution.Simple.Utils-         ( die', warn, info, createDirectoryIfMissingVerbose )+         ( die', warn, info, createDirectoryIfMissingVerbose, fromUTF8LBS ) import Distribution.Client.Setup          ( RepoContext(..) )  import Distribution.PackageDescription.Parsec          ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse+import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse  import           Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import           Distribution.Solver.Types.SourcePackage +import Data.Either+         ( rights ) import qualified Data.Map as Map import qualified Data.Set as Set import Control.Exception import Data.List (stripPrefix) import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress)@@ -241,7 +247,7 @@             " as explicitly requested (via command line / project configuration)"           return idxState         Nothing -> do-          mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)+          mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)           case mb_idxState' of             Nothing -> do               info verbosity "Using most recent state (could not read timestamp file)"@@ -359,7 +365,9 @@ readRepoIndex verbosity repoCtxt repo idxState =   handleNotFound $ do     when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo-    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    -- note that if this step fails due to a bad repo cache, the the procedure can still succeed by reading from the existing cache, which is updated regardless.+    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) `catchIO`+       (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e)     readPackageIndexCacheFile verbosity mkAvailablePackage                               (RepoIndex repoCtxt repo)                               idxState@@ -556,19 +564,68 @@ extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of   Tar.NormalFile content _-     | FilePath.Posix.takeFileName entrypath == "preferred-versions"+     | isPreferredVersions entrypath     -> Just prefs     where       entrypath = Tar.entryPath entry       prefs     = parsePreferredVersions content   _ -> Nothing +------------------------------------------------------------------------+-- Filename and parsers for 'preferred-versions' file.+--++-- | Expected name of the 'preferred-versions' file.+--+-- Contains special constraints, such as a preferred version of a package+-- or deprecations of certain package versions.+--+-- Expected format:+--+-- @+-- binary > 0.9.0.0 || < 0.9.0.0+-- text == 1.2.1.0+-- @+preferredVersions :: FilePath+preferredVersions = "preferred-versions"++-- | Does the given filename match with the expected name of 'preferred-versions'?+isPreferredVersions :: FilePath -> Bool+isPreferredVersions = (== preferredVersions) . takeFileName++-- | Parse `preferred-versions` file, ignoring any parse failures.+--+-- To obtain parse errors, use 'parsePreferredVersionsWarnings'. parsePreferredVersions :: ByteString -> [Dependency]-parsePreferredVersions = mapMaybe simpleParsec-                       . filter (not . isPrefixOf "--")-                       . lines-                       . BS.Char8.unpack -- TODO: Are we sure no unicode?+parsePreferredVersions = rights . parsePreferredVersionsWarnings +-- | Parser error of the `preferred-versions` file.+data PreferredVersionsParseError = PreferredVersionsParseError+    { preferredVersionsParsecError :: String+    -- ^ Parser error to show to a user.+    , preferredVersionsOriginalDependency :: String+    -- ^ Original input that produced the parser error.+    }+  deriving (Generic, Read, Show, Eq, Ord, Typeable)++-- | Parse `preferred-versions` file, collecting parse errors that can be shown+-- in error messages.+parsePreferredVersionsWarnings :: ByteString+                               -> [Either PreferredVersionsParseError Dependency]+parsePreferredVersionsWarnings =+  map parsePreference+  . filter (not . isPrefixOf "--")+  . lines+  . fromUTF8LBS+    where+      parsePreference :: String -> Either PreferredVersionsParseError Dependency+      parsePreference s = case eitherParsec s of+          Left err -> Left $ PreferredVersionsParseError+              { preferredVersionsParsecError = err+              , preferredVersionsOriginalDependency = s+              }+          Right dep -> Right dep+ ------------------------------------------------------------------------ -- Reading and updating the index cache --@@ -705,10 +762,23 @@      entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do         case isTarGz file of-            Nothing -> do-                unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $-                    info verbosity $ "Skipping " ++ file-                return Nothing+            Nothing+              | isPreferredVersions file -> do+                  contents <- BS.readFile (localDir </> file)+                  let versionPreferencesParsed = parsePreferredVersionsWarnings contents+                  let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed+                  unless (null warnings) $ do+                      warn verbosity $+                          "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "+                              ++ (localDir </> file)+                      for_ warnings $ \err -> do+                          warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err+                          warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err+                  return $ Just $ NoIndexCachePreference versionPreferences+              | otherwise -> do+                  unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $+                      info verbosity $ "Skipping " ++ file+                  return Nothing             Just pkgid | cabalPath `Set.member` contentSet -> do                 contents <- BSS.readFile (localDir </> cabalPath)                 for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->@@ -725,9 +795,20 @@                     Just ce -> return (Just ce)                     Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file +    let (prefs, gpds) = partitionEithers $ map+            (\case+                NoIndexCachePreference deps -> Left deps+                CacheGPD gpd _ -> Right gpd+            )+            entries+     info verbosity $ "Entries in file+noindex repository " ++ unRepoName name-    for_ entries $ \(CacheGPD gpd _) ->+    for_ gpds $ \gpd ->         info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)+    unless (null prefs) $ do+        info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name+        for_ (concat prefs) $ \pref ->+            info verbosity ("* " ++ prettyShow pref)      callback entries   where@@ -772,8 +853,8 @@ readPackageIndexCacheFile verbosity mkPkg index idxState     | localNoIndex index = do         cache0 <- readNoIndexCache verbosity index-        pkgs   <- packageNoIndexFromCache verbosity mkPkg cache0-        pure (pkgs, [], emptyStateInfo)+        (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0+        pure (pkgs, prefs, emptyStateInfo)      | otherwise = do         cache0   <- readIndexCache verbosity index@@ -798,16 +879,23 @@     => Verbosity     -> (PackageEntry -> pkg)     -> NoIndexCache-    -> IO (PackageIndex pkg)-packageNoIndexFromCache _verbosity mkPkg cache =-     evaluate $ PackageIndex.fromList pkgs+    -> IO (PackageIndex pkg, [Dependency])+packageNoIndexFromCache _verbosity mkPkg cache = do+    let (pkgs, prefs) = packageListFromNoIndexCache+    pkgIndex <- evaluate $ PackageIndex.fromList pkgs+    pure (pkgIndex, prefs)   where-    pkgs =-        [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0-        | CacheGPD gpd bs <- noIndexCacheEntries cache-        , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd-        ]+    packageListFromNoIndexCache :: ([pkg], [Dependency])+    packageListFromNoIndexCache = foldr go mempty (noIndexCacheEntries cache) +    go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])+    go (CacheGPD gpd bs) (pkgs, prefs) =+        let pkgId = package $ Distribution.PackageDescription.packageDescription gpd+        in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs)+    go (NoIndexCachePreference deps) (pkgs, prefs) =+        (pkgs, deps ++ prefs)++ -- | Read package list -- -- The result package releases and preference entries are guaranteed@@ -968,7 +1056,7 @@ -- timestamp you would use to revert to this version currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp currentIndexTimestamp verbosity repoCtxt r = do-    mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)+    mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)     case mb_is of       Just (IndexStateTime ts) -> return ts       _ -> do@@ -976,13 +1064,15 @@         return (isiHeadTime isi)  -- | Read the 'IndexState' from the filesystem-readIndexTimestamp :: Index -> IO (Maybe RepoIndexState)-readIndexTimestamp index+readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)+readIndexTimestamp verbosity index   = fmap simpleParsec (readFile (timestampFile index))         `catchIO` \e ->             if isDoesNotExistError e                 then return Nothing-                else ioError e+                else do+                   warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e+                   return Nothing  -- | Optimise sharing of equal values inside 'Cache' --@@ -996,7 +1086,7 @@     -- If/when we redo the binary serialisation via e.g. CBOR and we     -- are able to use incremental decoding, we may want to move the     -- hash-consing into the incremental deserialisation, or-    -- alterantively even do something like+    -- alternatively even do something like     -- http://cbor.schmorp.de/value-sharing     --     go _ _ [] = []@@ -1052,6 +1142,7 @@  data NoIndexCacheEntry     = CacheGPD GenericPackageDescription !BSS.ByteString+    | NoIndexCachePreference [Dependency]   deriving (Eq,Show,Generic)  instance NFData IndexCacheEntry where@@ -1061,6 +1152,7 @@  instance NFData NoIndexCacheEntry where     rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs+    rnf (NoIndexCachePreference dep) = rnf dep  cacheEntryTimestamp :: IndexCacheEntry -> Timestamp cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp@@ -1080,13 +1172,25 @@  -- | We need to save only .cabal file contents instance Binary NoIndexCacheEntry where-    put (CacheGPD _ bs) = put bs+    put (CacheGPD _ bs) = do+        put (0 :: Word8)+        put bs+    put (NoIndexCachePreference dep) = do+        put (1 :: Word8)+        put dep      get = do-        bs <- get-        case parseGenericPackageDescriptionMaybe bs of-            Just gpd -> return (CacheGPD gpd bs)-            Nothing  -> fail "Failed to parse GPD"+        t :: Word8 <- get+        case t of+          0 -> do+            bs <- get+            case parseGenericPackageDescriptionMaybe bs of+                Just gpd -> return (CacheGPD gpd bs)+                Nothing  -> fail "Failed to parse GPD"+          1 -> do+            dep <- get+            pure $ NoIndexCachePreference dep+          _ -> fail "Failed to parse NoIndexCacheEntry"  instance Structured NoIndexCacheEntry where     structure = nominalStructure
src/Distribution/Client/Init.hs view
@@ -13,13 +13,52 @@ -- ----------------------------------------------------------------------------- -module Distribution.Client.Init (--    -- * Commands-    initCabal-  , incVersion+module Distribution.Client.Init+( -- * Commands+  initCmd+) where -  ) where+import qualified Distribution.Client.Init.Interactive.Command as Interactive+import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive+import qualified Distribution.Client.Init.Simple as Simple+import Distribution.Verbosity+import Distribution.Client.Setup (RepoContext)+import Distribution.Simple.Compiler+import Distribution.Simple.Program (ProgramDb)+import Distribution.Client.Init.Types+import Distribution.Simple.Setup+import Distribution.Client.IndexUtils+import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))+import Distribution.Client.Init.FileCreators -import Distribution.Client.Init.Command-  ( initCabal, incVersion )+-- | This is the main driver for the init script.+--+initCmd+    :: Verbosity+    -> PackageDBStack+    -> RepoContext+    -> Compiler+    -> ProgramDb+    -> InitFlags+    -> IO ()+initCmd v packageDBs repoCtxt comp progdb initFlags = do+    installedPkgIndex <- getInstalledPackages v comp packageDBs progdb+    sourcePkgDb <- getSourcePackages v repoCtxt+    hSetBuffering stdout NoBuffering+    settings <- createProject v installedPkgIndex sourcePkgDb initFlags+    writeProject settings+  where+    -- When no flag is set, default to interactive.+    --+    -- When `--interactive` is set, if we also set `--simple`,+    -- then we interactive generate a simple project with sensible defaults.+    --+    -- If `--simple` is not set, default to interactive. When the flag+    -- is explicitly set to `--non-interactive`, then we choose non-interactive.+    --+    createProject+      | fromFlagOrDefault False (simpleProject initFlags) =+          Simple.createProject+      | otherwise = case interactive initFlags of+        Flag False -> NonInteractive.createProject comp+        _ -> Interactive.createProject
− src/Distribution/Client/Init/Command.hs 
@@ -1,749 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Command--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Implementation of the 'cabal init' command, which creates an initial .cabal--- file for a project.-----------------------------------------------------------------------------------module Distribution.Client.Init.Command-  ( -- * Commands-    initCabal-  , incVersion--    -- * Helpers-  , getSimpleProject-  , getLibOrExec-  , getCabalVersion-  , getPackageName-  , getVersion-  , getLicense-  , getAuthorInfo-  , getHomepage-  , getSynopsis-  , getCategory-  , getExtraSourceFiles-  , getAppDir-  , getSrcDir-  , getGenTests-  , getTestDir-  , getLanguage-  , getGenComments-  , getModulesBuildToolsAndDeps-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import System.IO-  ( hSetBuffering, stdout, BufferMode(..) )-import System.Directory-  ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents )-import System.FilePath-  ( (</>), takeBaseName, equalFilePath )--import qualified Data.List.NonEmpty as NE-import qualified Data.Map as M-import Control.Monad-  ( (>=>) )-import Control.Arrow-  ( (&&&), (***) )--import Distribution.CabalSpecVersion-  ( CabalSpecVersion (..), showCabalSpecVersion )-import Distribution.Version-  ( Version, mkVersion, alterVersion, majorBoundVersion-  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )-import Distribution.ModuleName-  ( ModuleName )  -- And for the Text instance-import Distribution.InstalledPackageInfo-  ( InstalledPackageInfo, exposed )-import qualified Distribution.Package as P-import qualified Distribution.SPDX as SPDX-import Language.Haskell.Extension ( Language(..) )--import Distribution.Client.Init.Defaults-  ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir )-import Distribution.Client.Init.FileCreators-  ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs-  , createTestSuiteIfEligible, writeCabalFile )-import Distribution.Client.Init.Prompt-  ( prompt, promptYesNo, promptStr, promptList, maybePrompt-  , promptListOptional )-import Distribution.Client.Init.Utils-  ( eligibleForTestSuite,  message )-import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..), Category(..)-  , displayPackageType )-import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,-    SourceFileEntry(..),-    scanForModules, neededBuildPrograms )--import Distribution.Simple.Flag-  ( maybeToFlag )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Simple.Configure-  ( getInstalledPackages )-import Distribution.Simple.Compiler-  ( PackageDBStack, Compiler )-import Distribution.Simple.Program-  ( ProgramDb )-import Distribution.Simple.PackageIndex-  ( InstalledPackageIndex, moduleNameIndex )-import Distribution.Simple.Utils-  ( die' )--import Distribution.Solver.Types.PackageIndex-  ( elemByPackageName )--import Distribution.Client.IndexUtils-  ( getSourcePackages )-import Distribution.Client.Types-  ( SourcePackageDb(..) )-import Distribution.Client.Setup-  ( RepoContext(..) )--initCabal :: Verbosity-          -> PackageDBStack-          -> RepoContext-          -> Compiler-          -> ProgramDb-          -> InitFlags-          -> IO ()-initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do--  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-  sourcePkgDb <- getSourcePackages verbosity repoCtxt--  hSetBuffering stdout NoBuffering--  initFlags' <- extendFlags verbosity installedPkgIndex sourcePkgDb initFlags--  case license initFlags' of-    Flag SPDX.NONE -> return ()-    _              -> writeLicense initFlags'-  writeChangeLog initFlags'-  createDirectories (sourceDirs initFlags')-  createLibHs initFlags'-  createDirectories (applicationDirs initFlags')-  createMainHs initFlags'-  createTestSuiteIfEligible initFlags'-  success <- writeCabalFile initFlags'--  when success $ generateWarnings initFlags'--------------------------------------------------------------------------------  Flag acquisition  ------------------------------------------------------------------------------------------------------------------------------------- | Fill in more details in InitFlags by guessing, discovering, or prompting--- the user.-extendFlags :: Verbosity -> InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags-extendFlags verbosity pkgIx sourcePkgDb =-      getSimpleProject-  >=> getLibOrExec-  >=> getCabalVersion-  >=> getPackageName verbosity sourcePkgDb False-  >=> getVersion-  >=> getLicense-  >=> getAuthorInfo-  >=> getHomepage-  >=> getSynopsis-  >=> getCategory-  >=> getExtraSourceFiles-  >=> getAppDir-  >=> getSrcDir-  >=> getGenTests-  >=> getTestDir-  >=> getLanguage-  >=> getGenComments-  >=> getModulesBuildToolsAndDeps pkgIx---- | Combine two actions which may return a value, preferring the first. That---   is, run the second action only if the first doesn't return a value.-infixr 1 ?>>-(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)-f ?>> g = do-  ma <- f-  if isJust ma-    then return ma-    else g---- | Ask if a simple project with sensible defaults should be created.-getSimpleProject :: InitFlags -> IO InitFlags-getSimpleProject flags = do-  simpleProj <-     return (flagToMaybe $ simpleProject flags)-                ?>> maybePrompt flags-                    (promptYesNo-                      "Should I generate a simple project with sensible defaults"-                      (Just True))-  return $ case maybeToFlag simpleProj of-    Flag True ->-      flags { interactive = Flag False-            , simpleProject = Flag True-            , packageType = Flag LibraryAndExecutable-            , cabalVersion = Flag defaultCabalVersion-            }-    simpleProjFlag@_ ->-      flags { simpleProject = simpleProjFlag }----- | Get the version of the cabal spec to use.------ The spec version can be specified by the InitFlags cabalVersion field. If--- none is specified then the user is prompted to pick from a list of--- supported versions (see code below).-getCabalVersion :: InitFlags -> IO InitFlags-getCabalVersion flags = do-  cabVer <-     return (flagToMaybe $ cabalVersion flags)-            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`-                                  promptList "Please choose version of the Cabal specification to use"-                                  [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0]-                                  (Just defaultCabalVersion) displayCabalVersion False)-            ?>> return (Just defaultCabalVersion)--  return $  flags { cabalVersion = maybeToFlag cabVer }--  where-    displayCabalVersion :: CabalSpecVersion -> String-    displayCabalVersion v = case v of-      CabalSpecV1_10 -> "1.10   (legacy)"-      CabalSpecV2_0  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"-      CabalSpecV2_2  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"-      CabalSpecV2_4  -> "2.4    (+ support for '**' globbing)"-      CabalSpecV3_0  -> "3.0    (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"-      _              -> showCabalSpecVersion v------ | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess. It looks at the SourcePackageDb to avoid---   using an existing package name.-getPackageName :: Verbosity -> SourcePackageDb -> Bool -> InitFlags -> IO InitFlags-getPackageName verbosity sourcePkgDb forceAsk flags = do-  guess <- maybe (getCurrentDirectory >>= guessPackageName) pure-             =<< traverse guessPackageName (flagToMaybe $ packageDir flags)--  pkgName' <- case (flagToMaybe $ packageName flags) >>= maybeForceAsk of-    Just pkgName -> return $ Just $ pkgName-    _ -> maybePrompt flags (prompt "Package name" (Just guess))-  let pkgName = fromMaybe guess pkgName'--  chooseAgain <- if isPkgRegistered pkgName-                   then do-                     answer' <- maybePrompt flags (promptYesNo (promptOtherNameMsg pkgName) (Just True))-                     case answer' of-                       Just answer -> return answer-                       _ -> die' verbosity $ inUseMsg pkgName-                 else-                   return False--  if chooseAgain-    then getPackageName verbosity sourcePkgDb True flags-    else return $ flags { packageName = Flag pkgName }--  where-    maybeForceAsk x = if forceAsk then Nothing else Just x--    isPkgRegistered pkg = elemByPackageName (packageIndex sourcePkgDb) pkg--    inUseMsg pkgName = "The name " ++ (P.unPackageName pkgName) ++-                       " is already in use by another package on Hackage."--    promptOtherNameMsg pkgName = (inUseMsg pkgName) ++-                                 " Do you want to choose a different name"---- | Package version: use 0.1.0.0 as a last resort, but try prompting the user---  if possible.-getVersion :: InitFlags -> IO InitFlags-getVersion flags = do-  let v = Just $ mkVersion [0,1,0,0]-  v' <-     return (flagToMaybe $ version flags)-        ?>> maybePrompt flags (prompt "Package version" v)-        ?>> return v-  return $ flags { version = maybeToFlag v' }---- | Choose a license for the package.------ The license can come from Initflags (license field), if it is not present--- then prompt the user from a predefined list of licenses.-getLicense :: InitFlags -> IO InitFlags-getLicense flags = do-  elic <- return (fmap Right $ flagToMaybe $ license flags)-      ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True)--  case elic of-      Nothing          -> return flags { license = NoFlag }-      Just (Right lic) -> return flags { license = Flag lic }-      Just (Left str)  -> case eitherParsec str of-          Right lic -> return flags { license = Flag lic }-          -- on error, loop-          Left err -> do-              putStrLn "The license must be a valid SPDX expression."-              putStrLn err-              getLicense flags-  where-    -- perfectly we'll have this and writeLicense (in FileCreators)-    -- in a single file-    listedLicenses =-      SPDX.NONE :-      map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))-      [ SPDX.BSD_2_Clause-      , SPDX.BSD_3_Clause-      , SPDX.Apache_2_0-      , SPDX.MIT-      , SPDX.MPL_2_0-      , SPDX.ISC--      , SPDX.GPL_2_0_only-      , SPDX.GPL_3_0_only-      , SPDX.LGPL_2_1_only-      , SPDX.LGPL_3_0_only-      , SPDX.AGPL_3_0_only--      , SPDX.GPL_2_0_or_later-      , SPDX.GPL_3_0_or_later-      , SPDX.LGPL_2_1_or_later-      , SPDX.LGPL_3_0_or_later-      , SPDX.AGPL_3_0_or_later-      ]---- | The author's name and email. Prompt, or try to guess from an existing---   darcs repo.-getAuthorInfo :: InitFlags -> IO InitFlags-getAuthorInfo flags = do-  (authorName, authorEmail)  <--    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail-  authorName'  <-     return (flagToMaybe $ author flags)-                  ?>> maybePrompt flags (promptStr "Author name" authorName)-                  ?>> return authorName--  authorEmail' <-     return (flagToMaybe $ email flags)-                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)-                  ?>> return authorEmail--  return $ flags { author = maybeToFlag authorName'-                 , email  = maybeToFlag authorEmail'-                 }---- | Prompt for a homepage URL for the package.-getHomepage :: InitFlags -> IO InitFlags-getHomepage flags = do-  hp  <- queryHomepage-  hp' <-     return (flagToMaybe $ homepage flags)-         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)-         ?>> return hp--  return $ flags { homepage = maybeToFlag hp' }---- | Right now this does nothing, but it could be changed to do some---   intelligent guessing.-queryHomepage :: IO (Maybe String)-queryHomepage = return Nothing     -- get default remote darcs repo?---- | Prompt for a project synopsis.-getSynopsis :: InitFlags -> IO InitFlags-getSynopsis flags = do-  syn <-     return (flagToMaybe $ synopsis flags)-         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)--  return $ flags { synopsis = maybeToFlag syn }---- | Prompt for a package category.---   Note that it should be possible to do some smarter guessing here too, i.e.---   look at the name of the top level source directory.-getCategory :: InitFlags -> IO InitFlags-getCategory flags = do-  cat <-     return (flagToMaybe $ category flags)-         ?>> fmap join (maybePrompt flags-                         (promptListOptional "Project category" [Codec ..]))-  return $ flags { category = maybeToFlag cat }---- | Try to guess extra source files (don't prompt the user).-getExtraSourceFiles :: InitFlags -> IO InitFlags-getExtraSourceFiles flags = do-  extraSrcFiles <-     return (extraSrc flags)-                   ?>> Just `fmap` guessExtraSourceFiles flags--  return $ flags { extraSrc = extraSrcFiles }--defaultChangeLog :: FilePath-defaultChangeLog = "CHANGELOG.md"---- | Try to guess things to include in the extra-source-files field.---   For now, we just look for things in the root directory named---   'readme', 'changes', or 'changelog', with any sort of---   capitalization and any extension.-guessExtraSourceFiles :: InitFlags -> IO [FilePath]-guessExtraSourceFiles flags = do-  dir <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  files <- getDirectoryContents dir-  let extraFiles = filter isExtra files-  if any isLikeChangeLog extraFiles-    then return extraFiles-    else return (defaultChangeLog : extraFiles)--  where-    isExtra = likeFileNameBase ("README" : changeLogLikeBases)-    isLikeChangeLog = likeFileNameBase changeLogLikeBases-    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName-    changeLogLikeBases = ["CHANGES", "CHANGELOG"]---- | Ask whether the project builds a library or executable.-getLibOrExec :: InitFlags -> IO InitFlags-getLibOrExec flags = do-  pkgType <-     return (flagToMaybe $ packageType flags)-           ?>> maybePrompt flags (either (const Executable) id `fmap`-                                   promptList "What does the package build"-                                   [Executable, Library, LibraryAndExecutable]-                                   Nothing displayPackageType False)-           ?>> return (Just Executable)--  -- If this package contains an executable, get the main file name.-  mainFile <- if pkgType == Just Library then return Nothing else-                    getMainFile flags--  return $ flags { packageType = maybeToFlag pkgType-                 , mainIs = maybeToFlag mainFile-                 }----- | Try to guess the main file of the executable, and prompt the user to choose--- one of them. Top-level modules including the word 'Main' in the file name--- will be candidates, and shorter filenames will be preferred.-getMainFile :: InitFlags -> IO (Maybe FilePath)-getMainFile flags =-  return (flagToMaybe $ mainIs flags)-  ?>> do-    candidates <- guessMainFileCandidates flags-    let showCandidate = either (++" (does not yet exist, but will be created)") id-        defaultFile = listToMaybe candidates-    maybePrompt flags (either id (either id id) `fmap`-                       promptList "What is the main module of the executable"-                       candidates-                       defaultFile showCandidate True)-      ?>> return (fmap (either id id) defaultFile)---- | Ask if a test suite should be generated for the library.-getGenTests :: InitFlags -> IO InitFlags-getGenTests flags = do-  genTests <-     return (flagToMaybe $ initializeTestSuite flags)-                  -- Only generate a test suite if the package contains a library.-              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing-              ?>> maybePrompt flags-                  (promptYesNo-                    "Should I generate a test suite for the library"-                    (Just True))-  return $ flags { initializeTestSuite = maybeToFlag genTests }---- | Ask for the test suite root directory.-getTestDir :: InitFlags -> IO InitFlags-getTestDir flags = do-  dirs <- return (testDirs flags)-              -- Only need testDirs when test suite generation is enabled.-          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing-          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt-                   flags-                   (promptList "Test directory" ["test"] (Just "test") id True))--  return $ flags { testDirs = dirs }---- | Ask for the Haskell base language of the package.-getLanguage :: InitFlags -> IO InitFlags-getLanguage flags = do-  lang <-     return (flagToMaybe $ language flags)-          ?>> maybePrompt flags-                (either UnknownLanguage id `fmap`-                  promptList "What base language is the package written in"-                  [Haskell2010, Haskell98]-                  (Just Haskell2010) prettyShow True)-          ?>> return (Just Haskell2010)--  if invalidLanguage lang-    then putStrLn invalidOtherLanguageMsg >> getLanguage flags-    else return $ flags { language = maybeToFlag lang }--  where-    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t-    invalidLanguage _ = False--    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++-                              "Please enter a different language."---- | Ask whether to generate explanatory comments.-getGenComments :: InitFlags -> IO InitFlags-getGenComments flags = do-  genComments <-     return (not <$> flagToMaybe (noComments flags))-                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))-                 ?>> return (Just False)-  return $ flags { noComments = maybeToFlag (fmap not genComments) }-  where-    promptMsg = "Add informative comments to each field in the cabal file (y/n)"---- | Ask for the application root directory.-getAppDir :: InitFlags -> IO InitFlags-getAppDir flags = do-  appDirs <- noAppDirIfLibraryOnly-    ?>> guessAppDir flags-    ?>> promptUserForApplicationDir-    ?>> setDefault-  return $ flags { applicationDirs = appDirs }-  where-    -- If the packageType==Library, ignore defined appdir.-    noAppDirIfLibraryOnly :: IO (Maybe [String])-    noAppDirIfLibraryOnly-      | packageType flags == Flag Library = return $ Just []-      | otherwise = return $ applicationDirs flags--    -- Set the default application directory.-    setDefault :: IO (Maybe [String])-    setDefault = pure (Just [defaultApplicationDir])--    -- Prompt the user for the application directory (defaulting to "app").-    -- Returns 'Nothing' if in non-interactive mode, otherwise will always-    -- return a 'Just' value ('Just []' if no separate application directory).-    promptUserForApplicationDir :: IO (Maybe [String])-    promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt-      flags-      (promptList-       ("Application " ++ mainFile ++ "directory")-       [[defaultApplicationDir], ["src-exe"], []]-        (Just [defaultApplicationDir])-       showOption True)--    showOption :: [String] -> String-    showOption [] = "(none)"-    showOption (x:_) = x--    -- The name-    mainFile :: String-    mainFile = case mainIs flags of-      Flag mainPath -> "(" ++ mainPath ++ ") "-      _             -> ""---- | Try to guess app directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'app'.-guessAppDir :: InitFlags -> IO (Maybe [String])-guessAppDir flags = do-  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  appIsDir <- doesDirectoryExist (dir </> "app")-  return $ if appIsDir-             then Just ["app"]-             else Nothing---- | Ask for the source (library) root directory.-getSrcDir :: InitFlags -> IO InitFlags-getSrcDir flags = do-  srcDirs <- noSourceDirIfExecutableOnly-    ?>> guessSourceDir flags-    ?>> promptUserForSourceDir-    ?>> setDefault--  return $ flags { sourceDirs = srcDirs }--  where-    -- If the packageType==Executable, then ignore source dir-    noSourceDirIfExecutableOnly :: IO (Maybe [String])-    noSourceDirIfExecutableOnly-      | packageType flags == Flag Executable = return $ Just []-      | otherwise = return $ sourceDirs flags--    -- Set the default source directory.-    setDefault :: IO (Maybe [String])-    setDefault = pure (Just [defaultSourceDir])--    -- Prompt the user for the source directory (defaulting to "app").-    -- Returns 'Nothing' if in non-interactive mode, otherwise will always-    -- return a 'Just' value ('Just []' if no separate application directory).-    promptUserForSourceDir :: IO (Maybe [String])-    promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt-      flags-      (promptList-       ("Library source directory")-       [[defaultSourceDir], ["lib"], ["src-lib"], []]-        (Just [defaultSourceDir])-       showOption True)--    showOption :: [String] -> String-    showOption [] = "(none)"-    showOption (x:_) = x----- | Try to guess source directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'src'.-guessSourceDir :: InitFlags -> IO (Maybe [String])-guessSourceDir flags = do-  dir      <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  srcIsDir <- doesDirectoryExist (dir </> "src")-  return $ if srcIsDir-             then Just ["src"]-             else Nothing---- | Check whether a potential source file is located in one of the---   source directories.-isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool-isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf-isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs---- | Get the list of exposed modules and extra tools needed to build them.-getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags-getModulesBuildToolsAndDeps pkgIx flags = do-  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags--  sourceFiles0 <- scanForModules dir--  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0--  Just mods <-      return (exposedModules flags)-           ?>> (return . Just . map moduleName $ sourceFiles)--  tools <-     return (buildTools flags)-           ?>> (return . Just . neededBuildPrograms $ sourceFiles)--  deps <-      return (dependencies flags)-           ?>> Just <$> importsToDeps flags-                        (fromString "Prelude" :  -- to ensure we get base as a dep-                           (   nub   -- only need to consider each imported package once-                             . filter (`notElem` mods)  -- don't consider modules from-                                                        -- this package itself-                             . concatMap imports-                             $ sourceFiles-                           )-                        )-                        pkgIx--  exts <-     return (otherExts flags)-          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)--  -- If we're initializing a library and there were no modules discovered-  -- then create an empty 'MyLib' module.-  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because-  -- then the executable needs to set 'other-modules: MyLib' or else the build-  -- fails.-  let (finalModsList, otherMods) = case (packageType flags, mods) of--        -- For an executable leave things as they are.-        (Flag Executable, _) -> (mods, otherModules flags)--        -- If a non-empty module list exists don't change anything.-        (_, (_:_)) -> (mods, otherModules flags)--        -- Library only: 'MyLib' in 'other-modules' only.-        (Flag Library, _) -> ([myLibModule], Nothing)--        -- For a 'LibraryAndExecutable' we need to have special handling.-        -- If we don't have a module list (Nothing or empty), then create a Lib.-        (_, []) ->-          if sourceDirs flags == applicationDirs flags-          then ([myLibModule], Just [myLibModule])-          else ([myLibModule], Nothing)--  return $ flags { exposedModules = Just finalModsList-                 , otherModules   = otherMods-                 , buildTools     = tools-                 , dependencies   = deps-                 , otherExts      = exts-                 }---- | Given a list of imported modules, retrieve the list of dependencies that--- provide those modules.-importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]-importsToDeps flags mods pkgIx = do--  let modMap :: M.Map ModuleName [InstalledPackageInfo]-      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx--      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]-      modDeps = map (id &&& flip M.lookup modMap) mods--  message flags "\nGuessing dependencies..."-  nub . catMaybes <$> traverse (chooseDep flags) modDeps---- Given a module and a list of installed packages providing it,--- choose a dependency (i.e. package + version range) to use for that--- module.-chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])-          -> IO (Maybe P.Dependency)--chooseDep flags (m, Nothing)-  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")-    >> return Nothing--chooseDep flags (m, Just [])-  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")-    >> return Nothing--    -- We found some packages: group them by name.-chooseDep flags (m, Just ps)-  = case pkgGroups of-      -- if there's only one group, i.e. multiple versions of a single package,-      -- we make it into a dependency, choosing the latest-ish version (see toDep).-      [grp] -> Just <$> toDep grp-      -- otherwise, we refuse to choose between different packages and make the user-      -- do it.-      grps  -> do message flags ("\nWarning: multiple packages found providing "-                                 ++ prettyShow m-                                 ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))-                  message flags "You will need to pick one and manually add it to the Build-depends: field."-                  return Nothing-  where-    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)--    desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags)--    -- Given a list of available versions of the same package, pick a dependency.-    toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency--    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*-    toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries--    -- Otherwise, choose the latest version and issue a warning.-    toDep pids  = do-      message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")-      return $ P.Dependency (P.pkgName . NE.head $ pids)-                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)-                            P.mainLibSet --TODO take into account sublibraries---- | Given a version, return an API-compatible (according to PVP) version range.------ If the boolean argument denotes whether to use a desugared--- representation (if 'True') or the new-style @^>=@-form (if--- 'False').------ Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the--- same as @0.4.*@).-pvpize :: Bool -> Version -> VersionRange-pvpize False  v = majorBoundVersion v-pvpize True   v = orLaterVersion v'-           `intersectVersionRanges`-           earlierVersion (incVersion 1 v')-  where v' = alterVersion (take 2) v---- | Increment the nth version component (counting from 0).-incVersion :: Int -> Version -> Version-incVersion n = alterVersion (incVersion' n)-  where-    incVersion' 0 []     = [1]-    incVersion' 0 (v:_)  = [v+1]-    incVersion' m []     = replicate m 0 ++ [1]-    incVersion' m (v:vs) = v : incVersion' (m-1) vs---- | Generate warnings for missing fields etc.-generateWarnings :: InitFlags -> IO ()-generateWarnings flags = do-  message flags ""-  when (synopsis flags `elem` [NoFlag, Flag ""])-       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")--  message flags "You may want to edit the .cabal file and add a Description field."
src/Distribution/Client/Init/Defaults.hs view
@@ -11,31 +11,182 @@ -- Default values to use in cabal init (if not specified in config/flags). -- -----------------------------------------------------------------------------+module Distribution.Client.Init.Defaults -module Distribution.Client.Init.Defaults (-    defaultApplicationDir-  , defaultSourceDir-  , defaultCabalVersion-  , myLibModule-  ) where+( -- * default init values+  defaultApplicationDir+, defaultSourceDir+, defaultCabalVersion+, defaultCabalVersions+, defaultPackageType+, defaultLicense+, defaultLicenseIds+, defaultMainIs+, defaultChangelog+, defaultCategories+, defaultInitFlags+, defaultLanguage+, defaultVersion+, defaultTestDir+  -- * MyLib defaults+, myLibModule+, myLibTestFile+, myLibFile+, myLibHs+, myExeHs+, myLibExeHs+, myTestHs+) where -import Prelude (String) -import Distribution.ModuleName-  ( ModuleName )  -- And for the Text instance-import qualified Distribution.ModuleName as ModuleName-  ( fromString )-import Distribution.CabalSpecVersion-  ( CabalSpecVersion (..))+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName(fromString)+import Distribution.CabalSpecVersion (CabalSpecVersion (..))+import Distribution.Client.Init.Types (PackageType(..), InitFlags(..), HsFilePath, toHsFilePath)+import qualified Distribution.SPDX.License as SPDX+import qualified Distribution.SPDX.LicenseId as SPDX+import Distribution.Simple.Flag (toFlag)+import Distribution.Verbosity (normal)+import Distribution.Types.Version+import Distribution.FieldGrammar.Newtypes+import Distribution.Simple (Language(..), License(..)) ++-- -------------------------------------------------------------------- --+-- Default flag and init values++defaultVersion :: Version+defaultVersion = mkVersion [0,1,0,0]+ defaultApplicationDir :: String defaultApplicationDir = "app"  defaultSourceDir :: String defaultSourceDir = "src" +defaultTestDir :: String+defaultTestDir = "test"+ defaultCabalVersion :: CabalSpecVersion-defaultCabalVersion = CabalSpecV2_4+defaultCabalVersion = CabalSpecV3_0 +defaultPackageType :: PackageType+defaultPackageType = Executable++defaultChangelog :: FilePath+defaultChangelog = "CHANGELOG.md"++defaultLicense :: CabalSpecVersion -> SpecLicense+defaultLicense csv+  | csv < CabalSpecV2_2 = SpecLicense $ Right AllRightsReserved+  | otherwise           = SpecLicense $ Left  SPDX.NONE++defaultMainIs :: HsFilePath+defaultMainIs = toHsFilePath "Main.hs"++defaultLanguage :: Language+defaultLanguage = Haskell2010++defaultLicenseIds :: [SPDX.LicenseId]+defaultLicenseIds =+    [ SPDX.BSD_2_Clause+    , SPDX.BSD_3_Clause+    , SPDX.Apache_2_0+    , SPDX.MIT+    , SPDX.MPL_2_0+    , SPDX.ISC+    , SPDX.GPL_2_0_only+    , SPDX.GPL_3_0_only+    , SPDX.LGPL_2_1_only+    , SPDX.LGPL_3_0_only+    , SPDX.AGPL_3_0_only+    , SPDX.GPL_2_0_or_later+    , SPDX.GPL_3_0_or_later+    , SPDX.LGPL_2_1_or_later+    , SPDX.LGPL_3_0_or_later+    , SPDX.AGPL_3_0_or_later+    ]++defaultCategories :: [String]+defaultCategories =+    [ "Codec"+    , "Concurrency"+    , "Control"+    , "Data"+    , "Database"+    , "Development"+    , "Distribution"+    , "Game"+    , "Graphics"+    , "Language"+    , "Math"+    , "Network"+    , "Sound"+    , "System"+    , "Testing"+    , "Text"+    , "Web"+    ]++defaultCabalVersions :: [CabalSpecVersion]+defaultCabalVersions =+    [ CabalSpecV1_24+    , CabalSpecV2_0+    , CabalSpecV2_2+    , CabalSpecV2_4+    , CabalSpecV3_0+    , CabalSpecV3_4+    ]++defaultInitFlags :: InitFlags+defaultInitFlags  = mempty { initVerbosity = toFlag normal }++-- -------------------------------------------------------------------- --+-- MyLib defaults+ myLibModule :: ModuleName myLibModule = ModuleName.fromString "MyLib"++myLibTestFile :: HsFilePath+myLibTestFile = toHsFilePath "MyLibTest.hs"++myLibFile :: HsFilePath+myLibFile = toHsFilePath "MyLib.hs"++-- | Default MyLib.hs file.  Used when no Lib.hs exists.+myLibHs :: String+myLibHs = unlines+  [ "module MyLib (someFunc) where"+  , ""+  , "someFunc :: IO ()"+  , "someFunc = putStrLn \"someFunc\""+  ]++myExeHs :: [String]+myExeHs =+    [ "module Main where"+    , ""+    , "main :: IO ()"+    , "main = putStrLn \"Hello, Haskell!\""+    ]++myLibExeHs :: [String]+myLibExeHs =+    [ "module Main where"+    , ""+    , "import qualified MyLib (someFunc)"+    , ""+    , "main :: IO ()"+    , "main = do"+    , "  putStrLn \"Hello, Haskell!\""+    , "  MyLib.someFunc"+    ]++-- | Default MyLibTest.hs file.+myTestHs :: String+myTestHs = unlines+  [ "module Main (main) where"+  , ""+  , "main :: IO ()"+  , "main = putStrLn \"Test suite not yet implemented.\""+  ]
src/Distribution/Client/Init/FileCreators.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -12,640 +13,303 @@ -- Functions to create files during 'cabal init'. -- -------------------------------------------------------------------------------module Distribution.Client.Init.FileCreators (--    -- * Commands-    writeLicense-  , writeChangeLog-  , createDirectories-  , createLibHs-  , createMainHs-  , createTestSuiteIfEligible-  , writeCabalFile--  -- * For testing-  , generateCabalFile-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import System.FilePath-  ( (</>), (<.>), takeExtension )--import Distribution.Types.Dependency-import Distribution.Types.VersionRange+module Distribution.Client.Init.FileCreators+( -- * Commands+  writeProject+, writeLicense+, writeChangeLog+, prepareLibTarget+, prepareExeTarget+, prepareTestTarget+) where -import Data.Time-  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )-import System.Directory-  ( getCurrentDirectory, doesFileExist, copyFile-  , createDirectoryIfMissing )+import Prelude hiding (writeFile, readFile)+import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile, readFile) -import Text.PrettyPrint hiding ((<>), mode, cat)+import qualified Data.Set as Set (member)  import Distribution.Client.Init.Defaults-  ( defaultCabalVersion, myLibModule ) import Distribution.Client.Init.Licenses   ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )-import Distribution.Client.Init.Utils-  ( eligibleForTestSuite, message )-import Distribution.Client.Init.Types-  ( InitFlags(..), BuildType(..), PackageType(..) )+import Distribution.Client.Init.Types hiding (putStrLn, putStr, message)+import qualified Distribution.Client.Init.Types as T+import Distribution.Fields.Pretty (PrettyField(..), showFields')+import qualified Distribution.SPDX as SPDX+import Distribution.Types.PackageName+import Distribution.Client.Init.Format+import Distribution.CabalSpecVersion (showCabalSpecVersion) -import Distribution.CabalSpecVersion-import Distribution.Compat.Newtype-  ( Newtype )-import Distribution.Fields.Field-  ( FieldName )-import Distribution.License-  ( licenseFromSPDX )-import qualified Distribution.ModuleName as ModuleName-  ( toFilePath )+import System.FilePath ((</>), (<.>)) import Distribution.FieldGrammar.Newtypes-  ( SpecVersion(..) )-import Distribution.PackageDescription.FieldGrammar-  ( formatDependencyList, formatExposedModules, formatHsSourceDirs,-    formatOtherExtensions, formatOtherModules, formatExtraSourceFiles )-import Distribution.Simple.Flag-  ( maybeToFlag )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Simple.Utils-  ( toUTF8BS )-import Distribution.Fields.Pretty-  ( PrettyField(..), showFields' )+import Distribution.License (licenseToSPDX) -import qualified Distribution.SPDX as SPDX+-- -------------------------------------------------------------------- --+--  File generation -import Distribution.Utils.Path -- TODO+writeProject :: Interactive m => ProjectSettings -> m ()+writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)+    | null pkgName = do+      message opts T.Error "no package name given, so no .cabal file can be generated\n"+    | otherwise = do -------------------------------------------------------------------------------  File generation  ----------------------------------------------------------------------------------------------------------------------------------+      -- clear prompt history a bit"+      message opts T.Log+        $ "Using cabal specification: "+        ++ showCabalSpecVersion (_optCabalSpec opts) --- | Write the LICENSE file, as specified in the InitFlags license field.------ For licences that contain the author's name(s), the values are taken--- from the 'authors' field of 'InitFlags', and if not specified will--- be the string "???".------ If the license type is unknown no license file will be created and--- a warning will be raised.-writeLicense :: InitFlags -> IO ()-writeLicense flags = do-  message flags "\nGenerating LICENSE..."-  year <- show <$> getCurrentYear-  let authors = fromMaybe "???" . flagToMaybe . author $ flags-  let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId-      isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid-      isSimpleLicense _                                                            = Nothing-  let licenseFile =-        case flagToMaybe (license flags) >>= isSimpleLicense of-          Just SPDX.BSD_2_Clause  -> Just $ bsd2 authors year-          Just SPDX.BSD_3_Clause  -> Just $ bsd3 authors year-          Just SPDX.Apache_2_0    -> Just apache20-          Just SPDX.MIT           -> Just $ mit authors year-          Just SPDX.MPL_2_0       -> Just mpl20-          Just SPDX.ISC           -> Just $ isc authors year+      writeLicense opts pkgDesc+      writeChangeLog opts pkgDesc -          -- GNU license come in "only" and "or-later" flavours-          -- license file used are the same.-          Just SPDX.GPL_2_0_only  -> Just gplv2-          Just SPDX.GPL_3_0_only  -> Just gplv3-          Just SPDX.LGPL_2_1_only -> Just lgpl21-          Just SPDX.LGPL_3_0_only -> Just lgpl3-          Just SPDX.AGPL_3_0_only -> Just agplv3+      let pkgFields = mkPkgDescription opts pkgDesc+          commonStanza = mkCommonStanza opts -          Just SPDX.GPL_2_0_or_later  -> Just gplv2-          Just SPDX.GPL_3_0_or_later  -> Just gplv3-          Just SPDX.LGPL_2_1_or_later -> Just lgpl21-          Just SPDX.LGPL_3_0_or_later -> Just lgpl3-          Just SPDX.AGPL_3_0_or_later -> Just agplv3+      libStanza <- prepareLibTarget opts libTarget+      exeStanza <- prepareExeTarget opts exeTarget+      testStanza <- prepareTestTarget opts testTarget -          _ -> Nothing+      (reusedCabal, cabalContents) <- writeCabalFile opts $+        pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] -  case licenseFile of-    Just licenseText -> writeFileSafe flags "LICENSE" licenseText-    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."+      when (null $ _pkgSynopsis pkgDesc) $+        message opts T.Warning "No synopsis given. You should edit the .cabal file and add one." --- | Returns the current calendar year.-getCurrentYear :: IO Integer-getCurrentYear = do-  u <- getCurrentTime-  z <- getCurrentTimeZone-  let l = utcToLocalTime z u-      (y, _, _) = toGregorian $ localDay l-  return y+      message opts T.Info "You may want to edit the .cabal file and add a Description field." -defaultChangeLog :: FilePath-defaultChangeLog = "CHANGELOG.md"+      when reusedCabal $ do+        existingCabal <- readFile $ unPackageName (_optPkgName opts) ++ ".cabal"+        when (existingCabal /= cabalContents) $+          message opts T.Warning "A .cabal file was found and not updated, if updating is desired please use the '--overwrite' option." --- | Writes the changelog to the current directory.-writeChangeLog :: InitFlags -> IO ()-writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do-  message flags ("Generating "++ defaultChangeLog ++"...")-  writeFileSafe flags defaultChangeLog changeLog- where-  changeLog = unlines-    [ "# Revision history for " ++ pname-    , ""-    , "## " ++ pver ++ " -- YYYY-mm-dd"-    , ""-    , "* First version. Released on an unsuspecting world."-    ]-  pname = maybe "" prettyShow $ flagToMaybe $ packageName flags-  pver = maybe "" prettyShow $ flagToMaybe $ version flags+      -- clear out last line for presentation.+      T.putStrLn ""+  where+    pkgName = unPackageName $ _optPkgName opts --- | Creates and writes the initialized .cabal file.------ Returns @False@ if no package name is specified, @True@ otherwise.-writeCabalFile :: InitFlags -> IO Bool-writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do-  message flags "Error: no package name provided."-  return False-writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = prettyShow p ++ ".cabal"-  message flags $ "Generating " ++ cabalFileName ++ "..."-  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)-  return True --- | Write a file \"safely\", backing up any existing version (unless---   the overwrite flag is set).-writeFileSafe :: InitFlags -> FilePath -> String -> IO ()-writeFileSafe flags fileName content = do-  moveExistingFile flags fileName-  writeFile fileName content---- | Create directories, if they were given, and don't already exist.-createDirectories :: Maybe [String] -> IO ()-createDirectories mdirs = case mdirs of-  Just dirs -> for_ dirs (createDirectoryIfMissing True)-  Nothing   -> return ()---- | Create MyLib.hs file, if its the only module in the liste.-createLibHs :: InitFlags -> IO ()-createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do-  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"-  case sourceDirs flags of-    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)-    _                -> writeLibHs flags modFilePath---- | Write a MyLib.hs file if it doesn't already exist.-writeLibHs :: InitFlags -> FilePath -> IO ()-writeLibHs flags libPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let libFullPath = dir </> libPath-  exists <- doesFileExist libFullPath-  unless exists $ do-    message flags $ "Generating " ++ libPath ++ "..."-    writeFileSafe flags libFullPath myLibHs---- | Default MyLib.hs file.  Used when no Lib.hs exists.-myLibHs :: String-myLibHs = unlines-  [ "module MyLib (someFunc) where"-  , ""-  , "someFunc :: IO ()"-  , "someFunc = putStrLn \"someFunc\""-  ]+prepareLibTarget+    :: Interactive m+    => WriteOpts+    -> Maybe LibTarget+    -> m (PrettyField FieldAnnotation)+prepareLibTarget _ Nothing = return PrettyEmpty+prepareLibTarget opts (Just libTarget) = do+    void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs+    -- avoid writing when conflicting exposed paths may+    -- exist.+    when (expMods == (myLibModule :| [])) . void $+      writeFileSafe opts libPath myLibHs --- | Create Main.hs, but only if we are init'ing an executable and---   the mainIs flag has been provided.-createMainHs :: InitFlags -> IO ()-createMainHs flags =-  if hasMainHs flags then-    case applicationDirs flags of-      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)-      _ -> writeMainHs flags mainFile-  else return ()+    return $ mkLibStanza opts libTarget   where-    mainFile = case mainIs flags of-      Flag x -> x-      NoFlag -> error "createMainHs: no mainIs"+    expMods = _libExposedModules libTarget+    srcDirs = _libSourceDirs libTarget+    libPath = case srcDirs of+      path:_ -> path </> _hsFilePath myLibFile+      _ -> _hsFilePath myLibFile --- | Write a main file if it doesn't already exist.-writeMainHs :: InitFlags -> FilePath -> IO ()-writeMainHs flags mainPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let mainFullPath = dir </> mainPath-  exists <- doesFileExist mainFullPath-  unless exists $ do-      message flags $ "Generating " ++ mainPath ++ "..."-      writeFileSafe flags mainFullPath (mainHs flags)+prepareExeTarget+    :: Interactive m+    => WriteOpts+    -> Maybe ExeTarget+    -> m (PrettyField FieldAnnotation)+prepareExeTarget _ Nothing = return PrettyEmpty+prepareExeTarget opts (Just exeTarget) = do+    void $ writeDirectoriesSafe opts appDirs+    void $ writeFileSafe opts mainPath mainHs+    return $ mkExeStanza opts exeTarget+  where+    exeMainIs = _exeMainIs exeTarget+    pkgType = _optPkgType opts+    appDirs = _exeApplicationDirs exeTarget+    mainFile = _hsFilePath exeMainIs+    mainPath = case appDirs of+      appPath:_ -> appPath </> mainFile+      _ -> mainFile --- | Returns true if a main file exists.-hasMainHs :: InitFlags -> Bool-hasMainHs flags = case mainIs flags of-  Flag _ -> (packageType flags == Flag Executable-             || packageType flags == Flag LibraryAndExecutable)-  _ -> False+    mainHs = unlines . mkLiterate exeMainIs $+      if pkgType == LibraryAndExecutable+      then myLibExeHs+      else myExeHs --- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.------   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.-mainHs :: InitFlags -> String-mainHs flags = (unlines . map prependPrefix) $ case packageType flags of-  Flag LibraryAndExecutable ->-    [ "module Main where"-    , ""-    , "import qualified MyLib (someFunc)"-    , ""-    , "main :: IO ()"-    , "main = do"-    , "  putStrLn \"Hello, Haskell!\""-    , "  MyLib.someFunc"-    ]-  _ ->-    [ "module Main where"-    , ""-    , "main :: IO ()"-    , "main = putStrLn \"Hello, Haskell!\""-    ]+prepareTestTarget+    :: Interactive m+    => WriteOpts+    -> Maybe TestTarget+    -> m (PrettyField FieldAnnotation)+prepareTestTarget _ Nothing = return PrettyEmpty+prepareTestTarget opts (Just testTarget) = do+    void $ writeDirectoriesSafe opts testDirs'+    void $ writeFileSafe opts testPath myTestHs+    return $ mkTestStanza opts testTarget   where-    prependPrefix :: String -> String-    prependPrefix "" = ""-    prependPrefix line-      | isLiterate = "> " ++ line-      | otherwise  = line-    isLiterate = case mainIs flags of-      Flag mainPath -> takeExtension mainPath == ".lhs"-      _             -> False+    testDirs' = _testDirs testTarget+    testMainIs = _hsFilePath $ _testMainIs testTarget+    testPath = case testDirs' of+      p:_ -> p </> testMainIs+      _ -> testMainIs --- | Create a test suite for the package if eligible.-createTestSuiteIfEligible :: InitFlags -> IO ()-createTestSuiteIfEligible flags =-  when (eligibleForTestSuite flags) $ do-    createDirectories (testDirs flags)-    createTestHs flags+writeCabalFile+    :: Interactive m+    => WriteOpts+    -> [PrettyField FieldAnnotation]+      -- ^ .cabal fields+    -> m (Bool, String)+writeCabalFile opts fields = do+    let cabalContents = showFields'+          annCommentLines+          postProcessFieldLines+          4 fields --- | The name of the test file to generate (if --tests is specified).-testFile :: String-testFile = "MyLibTest.hs"+    reusedCabal <- writeFileSafe opts cabalFileName cabalContents+    return (reusedCabal, cabalContents)+  where+    cabalFileName = pkgName ++ ".cabal"+    pkgName = unPackageName $ _optPkgName opts --- | Create MyLibTest.hs, but only if we are init'ing a library and---   the initializeTestSuite flag has been set.+-- | Write the LICENSE file. ----- It is up to the caller to verify that the package is eligible--- for test suite initialization (see eligibleForTestSuite).-createTestHs :: InitFlags -> IO ()-createTestHs flags =-  case testDirs flags of-    Just (testPath:_) -> writeTestHs flags (testPath </> testFile)-    _ -> writeMainHs flags testFile---- | Write a test file.-writeTestHs :: InitFlags -> FilePath -> IO ()-writeTestHs flags testPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let testFullPath = dir </> testPath-  exists <- doesFileExist testFullPath-  unless exists $ do-      message flags $ "Generating " ++ testPath ++ "..."-      writeFileSafe flags testFullPath testHs---- | Default MyLibTest.hs file.-testHs :: String-testHs = unlines-  [ "module Main (main) where"-  , ""-  , "main :: IO ()"-  , "main = putStrLn \"Test suite not yet implemented.\""-  ]----- | Move an existing file, if there is one, and the overwrite flag is---   not set.-moveExistingFile :: InitFlags -> FilePath -> IO ()-moveExistingFile flags fileName =-  unless (overwrite flags == Flag True) $ do-    e <- doesFileExist fileName-    when e $ do-      newName <- findNewName fileName-      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName-      copyFile fileName newName----- | Given a file path find a new name for the file that does not---   already exist.-findNewName :: FilePath -> IO FilePath-findNewName oldName = findNewName' 0+-- For licenses that contain the author's name(s), the values are taken+-- from the 'authors' field of 'InitFlags', and if not specified will+-- be the string "???".+--+-- If the license type is unknown no license file will be prepared and+-- a warning will be raised.+--+writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m ()+writeLicense writeOpts pkgDesc = do+  year <- show <$> getCurrentYear+  case licenseFile year (_pkgAuthor pkgDesc) of+    Just licenseText ->+      void $ writeFileSafe writeOpts "LICENSE" licenseText+    Nothing -> message writeOpts T.Warning "unknown license type, you must put a copy in LICENSE yourself."   where-    findNewName' :: Integer -> IO FilePath-    findNewName' n = do-      let newName = oldName <.> ("save" ++ show n)-      e <- doesFileExist newName-      if e then findNewName' (n+1) else return newName----- | Generate a .cabal file from an InitFlags structure.-generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c =-    showFields' annCommentLines postProcessFieldLines 4 $ catMaybes-  [ fieldP "cabal-version" (Flag . SpecVersion $ specVer)-      []-      False--  , field "name" (packageName c)-      ["Initial package description '" ++ fileName ++ "' generated by",-       "'cabal init'. For further documentation, see:",-       "  http://haskell.org/cabal/users-guide/",-       "",-       "The name of the package."]-      True--  , field  "version"       (version       c)-           ["The package version.",-            "See the Haskell package versioning policy (PVP) for standards",-            "guiding when and how versions should be incremented.",-            "https://pvp.haskell.org",-            "PVP summary:      +-+------- breaking API changes",-            "                  | | +----- non-breaking API additions",-            "                  | | | +--- code changes with no API change"]-           True--  , fieldS "synopsis"      (synopsis      c)-           ["A short (one-line) description of the package."]-           True--  , fieldS "description"   NoFlag-           ["A longer description of the package."]-           True--  , fieldS "homepage"      (homepage     c)-           ["URL for the project homepage or repository."]-           False--  , fieldS "bug-reports"   NoFlag-           ["A URL where users can report bugs."]-           True--  , fieldS  "license"      licenseStr-                ["The license under which the package is released."]-                True--  , case license c of-      NoFlag         -> Nothing-      Flag SPDX.NONE -> Nothing-      _ -> fieldS "license-file" (Flag "LICENSE")-                  ["The file containing the license text."]-                  True--  , fieldS "author"        (author       c)-           ["The package author(s)."]-           True--  , fieldS "maintainer"    (email        c)-           ["An email address to which users can send suggestions, bug reports, and patches."]-           True--  , fieldS "copyright"     NoFlag-           ["A copyright notice."]-           True--  , fieldS "category"      (either id prettyShow `fmap` category c)-           []-           True--  , fieldS "build-type"    (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")-           []-           False+    getLid (Left (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))) = Just lid+    getLid (Right l) = getLid . Left $ licenseToSPDX l+    getLid _ = Nothing -  , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))-           ["Extra files to be distributed with the package, such as examples or a README."]-           True-  ]-  ++-  (case packageType c of-     Flag Executable -> [executableStanza]-     Flag Library    -> [libraryStanza]-     Flag LibraryAndExecutable -> [libraryStanza, executableStanza]-     _               -> [])-  ++-  if eligibleForTestSuite c then [testSuiteStanza] else []+    licenseFile year auth = case getLid . getSpecLicense $ _pkgLicense pkgDesc of+      Just SPDX.BSD_2_Clause -> Just $ bsd2 auth year+      Just SPDX.BSD_3_Clause -> Just $ bsd3 auth year+      Just SPDX.Apache_2_0 -> Just apache20+      Just SPDX.MIT -> Just $ mit auth year+      Just SPDX.MPL_2_0 -> Just mpl20+      Just SPDX.ISC -> Just $ isc auth year+      Just SPDX.GPL_2_0_only -> Just gplv2+      Just SPDX.GPL_3_0_only -> Just gplv3+      Just SPDX.LGPL_2_1_only -> Just lgpl21+      Just SPDX.LGPL_3_0_only -> Just lgpl3+      Just SPDX.AGPL_3_0_only -> Just agplv3+      Just SPDX.GPL_2_0_or_later -> Just gplv2+      Just SPDX.GPL_3_0_or_later -> Just gplv3+      Just SPDX.LGPL_2_1_or_later -> Just lgpl21+      Just SPDX.LGPL_3_0_or_later -> Just lgpl3+      Just SPDX.AGPL_3_0_or_later -> Just agplv3+      _ -> Nothing +-- | Writes the changelog to the current directory.+--+writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m ()+writeChangeLog opts pkgDesc+  | Just docs <- _pkgExtraDocFiles pkgDesc+  , defaultChangelog `Set.member` docs = go+  | defaultChangelog `elem` _pkgExtraSrcFiles pkgDesc = go+  | otherwise = return ()  where-   specVer :: CabalSpecVersion-   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)--   licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c-              | otherwise               = prettyShow                   <$> license c--   generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation]-   generateBuildInfo buildType c' = catMaybes-     [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)-       [ case buildType of-                 LibBuild    -> "Modules included in this library but not exported."-                 ExecBuild -> "Modules included in this executable, other than Main."]-       True--     , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))-       ["LANGUAGE extensions used by modules in this package."]-       True--     , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)-       ["Other library packages from which modules are imported."]-       True--     , fieldPAla "hs-source-dirs" formatHsSourceDirs-       (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ case buildType of-         LibBuild -> sourceDirs c-         ExecBuild -> applicationDirs c)-       ["Directories containing source files."]-       True--     , fieldS "build-tools" (listFieldS $ buildTools c)-       ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]-       False--     , field "default-language" (language c)-       ["Base language which the package is written in."]-       True-     ]-     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).-     where-       buildDependencies :: Maybe [Dependency]-       buildDependencies = (++ myLibDep) <$> dependencies c'--       myLibDep :: [Dependency]-       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild-                      then case packageName c' of-                             Flag pkgName ->-                               [mkDependency pkgName anyVersion mainLibSet]-                             _ -> []-                  else []--       -- Only include 'MyLib' in 'other-modules' of the executable.-       otherModsFromFlag = otherModules c'-       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]-                   then Nothing-                   else otherModsFromFlag--   listFieldS :: Maybe [String] -> Flag String-   listFieldS Nothing = NoFlag-   listFieldS (Just []) = NoFlag-   listFieldS (Just xs) = Flag . intercalate ", " $ xs--   -- | Construct a 'PrettyField' from a field that can be automatically-   --   converted to a 'Doc' via 'display'.-   field :: Pretty t-         => FieldName-         -> Flag t-         -> [String]-         -> Bool-         -> Maybe (PrettyField FieldAnnotation)-   field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)--   -- | Construct a 'PrettyField' from a 'String' field.-   fieldS :: FieldName   -- ^ Name of the field-          -> Flag String -- ^ Field contents-          -> [String]    -- ^ Comment to explain the field-          -> Bool        -- ^ Should the field be included (commented out) even if blank?-          -> Maybe (PrettyField FieldAnnotation)-   fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag)--   -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.-   fieldP :: Pretty a-          => FieldName-          -> Flag a-          -> [String]-          -> Bool-          -> Maybe (PrettyField FieldAnnotation)-   fieldP fieldName fieldContentsFlag fieldComments includeField =-     fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField+  changeLog = unlines+    [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc)+    , ""+    , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd"+    , ""+    , "* First version. Released on an unsuspecting world."+    ] -   -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.-   fieldPAla-     :: (Pretty b, Newtype a b)-     => FieldName-     -> (a -> b)-     -> Flag a-     -> [String]-     -> Bool-     -> Maybe (PrettyField FieldAnnotation)-   fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =-     fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField+  go =+    void $ writeFileSafe opts defaultChangelog changeLog -   -- | Construct a 'PrettyField' from a 'Doc' Flag.-   fieldD :: FieldName   -- ^ Name of the field-          -> Flag Doc    -- ^ Field contents-          -> [String]    -- ^ Comment to explain the field-          -> Bool        -- ^ Should the field be included (commented out) even if blank?-          -> Maybe (PrettyField FieldAnnotation)-   fieldD fieldName fieldContentsFlag fieldComments includeField =-     case fieldContentsFlag of-       NoFlag ->-         -- If there is no content, optionally produce a commented out field.-         fieldSEmptyContents fieldName fieldComments includeField+-- -------------------------------------------------------------------- --+-- Utilities -       Flag fieldContents ->-         if isEmpty fieldContents-         then-           -- If the doc is empty, optionally produce a commented out field.-           fieldSEmptyContents fieldName fieldComments includeField-         else-           -- If the doc is not empty, produce a field.-           Just $ case (noComments c, minimal c) of-             -- If the "--no-comments" flag is set, strip comments.-             (Flag True, _) ->-               fieldSWithContents fieldName fieldContents []-             -- If the "--minimal" flag is set, strip comments.-             (_, Flag True) ->-               fieldSWithContents fieldName fieldContents []-             -- Otherwise, include comments.-             (_, _) ->-               fieldSWithContents fieldName fieldContents fieldComments+data WriteAction = Overwrite | Fresh | Existing deriving Eq -   -- | Optionally produce a field with no content (depending on flags).-   fieldSEmptyContents :: FieldName-                       -> [String]-                       -> Bool-                       -> Maybe (PrettyField FieldAnnotation)-   fieldSEmptyContents fieldName fieldComments includeField-     | not includeField || (minimal c == Flag True) =-         Nothing-     | otherwise =-         Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty)+instance Show WriteAction where+  show Overwrite = "Overwriting"+  show Fresh     = "Creating fresh"+  show Existing  = "Using existing" -   -- | Produce a field with content.-   fieldSWithContents :: FieldName-                      -> Doc-                      -> [String]-                      -> PrettyField FieldAnnotation-   fieldSWithContents fieldName fieldContents fieldComments =-     PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents+-- | Possibly generate a message to stdout, taking into account the+--   --quiet flag.+message :: Interactive m => WriteOpts -> T.Severity -> String -> m ()+message opts = T.message (_optVerbosity opts) -   executableStanza :: PrettyField FieldAnnotation-   executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes-     [ fieldS "main-is" (mainIs c)-       [".hs or .lhs file containing the Main module."]-       True-     ]-     ++-     generateBuildInfo ExecBuild c-     where-       exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)+-- | Write a file \"safely\" if it doesn't exist, backing up any existing version when+--   the overwrite flag is set.+writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m Bool+writeFileSafe opts fileName content = do+    exists <- doesFileExist fileName -   libraryStanza :: PrettyField FieldAnnotation-   libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes-     [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))-       ["Modules exported by the library."]-       True-     ]-     ++-     generateBuildInfo LibBuild c+    let action+          | exists && doOverwrite = Overwrite+          | not exists = Fresh+          | otherwise = Existing +    go exists -   testSuiteStanza :: PrettyField FieldAnnotation-   testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes-     [ field "default-language" (language c)-       ["Base language which the package is written in."]-       True+    message opts T.Log $ show action ++ " file " ++ fileName ++ "..."+    return $ action == Existing+  where+    doOverwrite = _optOverwrite opts -     , fieldS "type" (Flag "exitcode-stdio-1.0")-       ["The interface type and version of the test suite."]-       True+    go exists+      | not exists = do+        writeFile fileName content+      | exists && doOverwrite = do+        newName <- findNewPath fileName+        message opts T.Log $ concat+          [ fileName+          , " already exists. Backing up old version in "+          , newName+          ] -     , fieldPAla "hs-source-dirs" formatHsSourceDirs-       (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ testDirs c) -- TODO-       ["Directories containing source files."]-       True+        copyFile fileName newName   -- backups the old file+        removeExistingFile fileName -- removes the original old file+        writeFile fileName content  -- writes the new file+      | otherwise = return () -     , fieldS "main-is" (Flag testFile)-       ["The entrypoint to the test suite."]-       True+writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m Bool+writeDirectoriesSafe opts dirs = fmap or $ for dirs $ \dir -> do+    exists <- doesDirectoryExist dir -     , fieldPAla  "build-depends" formatDependencyList (maybeToFlag (dependencies c))-       ["Test dependencies."]-       True-     ]-     where-       testSuiteName =-         text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)+    let action+          | exists && doOverwrite = Overwrite+          | not exists = Fresh+          | otherwise = Existing --- | Annotations for cabal file PrettyField.-data FieldAnnotation = FieldAnnotation-  { annCommentedOut :: Bool-    -- ^ True iif the field and its contents should be commented out.-  , annCommentLines :: [String]-    -- ^ Comment lines to place before the field or section.-  }+    go dir exists --- | A field annotation instructing the pretty printer to comment out the field---   and any contents, with no comments.-commentedOutWithComments :: [String] -> FieldAnnotation-commentedOutWithComments = FieldAnnotation True . map ("-- " ++)+    message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..."+    return $ action == Existing+  where+    doOverwrite = _optOverwrite opts --- | A field annotation with the specified comment lines.-withComments :: [String] -> FieldAnnotation-withComments = FieldAnnotation False+    go dir exists+      | not exists = do+        createDirectory dir+      | exists && doOverwrite = do+        newDir <- findNewPath dir+        message opts T.Log $ concat+          [ dir+          , " already exists. Backing up old version in "+          , newDir+          ] --- | A field annotation with no comments.-annNoComments :: FieldAnnotation-annNoComments = FieldAnnotation False []+        renameDirectory dir newDir -- backups the old directory+        createDirectory dir        -- creates the new directory+      | otherwise = return () -postProcessFieldLines :: FieldAnnotation -> [String] -> [String]-postProcessFieldLines ann-  | annCommentedOut ann = map ("-- " ++)-  | otherwise = id+findNewPath :: Interactive m => FilePath -> m FilePath+findNewPath dir = go (0 :: Int)+  where+    go n = do+      let newDir = dir <.> ("save" ++ show n)+      e <- doesDirectoryExist newDir+      if e then go (succ n) else return newDir
+ src/Distribution/Client/Init/FlagExtractors.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE LambdaCase #-}+module Distribution.Client.Init.FlagExtractors+( -- * Flag extractors+  getPackageDir+, getSimpleProject+, getMinimal+, getCabalVersion+, getCabalVersionNoPrompt+, getPackageName+, getVersion+, getLicense+, getAuthor+, getEmail+, getHomepage+, getSynopsis+, getCategory+, getExtraSrcFiles+, getExtraDocFiles+, getPackageType+, getMainFile+, getInitializeTestSuite+, getTestDirs+, getLanguage+, getNoComments+, getAppDirs+, getSrcDirs+, getExposedModules+, getBuildTools+, getDependencies+, getOtherExts+, getOverwrite+, getOtherModules+  -- * Shared prompts+, simpleProjectPrompt+, initializeTestSuitePrompt+, packageTypePrompt+, testMainPrompt+, dependenciesPrompt+) where+++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last)++import qualified Data.List.NonEmpty as NEL++import Distribution.CabalSpecVersion (CabalSpecVersion(..))+import Distribution.Version (Version)+import Distribution.ModuleName (ModuleName)+import Distribution.Types.Dependency (Dependency(..))+import Distribution.Types.PackageName (PackageName)+import Distribution.Client.Init.Defaults+import Distribution.FieldGrammar.Newtypes (SpecLicense)+import Distribution.Client.Init.Types+import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe)+import Distribution.Simple.Flag (flagElim)++import Language.Haskell.Extension (Language(..), Extension(..))+import Distribution.Client.Init.Prompt+import qualified Data.Set as Set+import Distribution.Simple.PackageIndex+import Distribution.Client.Init.Utils++++-- -------------------------------------------------------------------- --+-- Flag extraction++getPackageDir :: Interactive m => InitFlags -> m FilePath+getPackageDir = flagElim getCurrentDirectory return . packageDir++-- | Ask if a simple project with sensible defaults should be created.+getSimpleProject :: Interactive m => InitFlags -> m Bool -> m Bool+getSimpleProject flags = fromFlagOrPrompt (simpleProject flags)++-- | Extract minimal cabal file flag (implies nocomments)+getMinimal :: Interactive m => InitFlags -> m Bool+getMinimal = return . fromFlagOrDefault False . minimal++-- | Get the version of the cabal spec to use.+--+-- The spec version can be specified by the InitFlags cabalVersion field. If+-- none is specified then the user is prompted to pick from a list of+-- supported versions (see code below).+getCabalVersion :: Interactive m => InitFlags -> m CabalSpecVersion -> m CabalSpecVersion+getCabalVersion flags = fromFlagOrPrompt (cabalVersion flags)++getCabalVersionNoPrompt :: InitFlags -> CabalSpecVersion+getCabalVersionNoPrompt = fromFlagOrDefault defaultCabalVersion . cabalVersion++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+getPackageName :: Interactive m => InitFlags -> m PackageName -> m PackageName+getPackageName flags = fromFlagOrPrompt (packageName flags)++-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user+--  if possible.+getVersion :: Interactive m => InitFlags -> m Version -> m Version+getVersion flags = fromFlagOrPrompt (version flags)++-- | Choose a license for the package.+-- The license can come from Initflags (license field), if it is not present+-- then prompt the user from a predefined list of licenses.+getLicense :: Interactive m => InitFlags -> m SpecLicense -> m SpecLicense+getLicense flags = fromFlagOrPrompt (license flags)++-- | The author's name. Prompt, or try to guess from an existing+--   darcs repo.+getAuthor :: Interactive m => InitFlags -> m String -> m String+getAuthor flags = fromFlagOrPrompt (author flags)++-- | The author's email. Prompt, or try to guess from an existing+--   darcs repo.+getEmail :: Interactive m => InitFlags -> m String -> m String+getEmail flags = fromFlagOrPrompt (email flags)++-- | Prompt for a homepage URL for the package.+getHomepage :: Interactive m => InitFlags -> m String -> m String+getHomepage flags = fromFlagOrPrompt (homepage flags)++-- | Prompt for a project synopsis.+getSynopsis :: Interactive m => InitFlags -> m String -> m String+getSynopsis flags = fromFlagOrPrompt (synopsis flags)++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+getCategory :: Interactive m => InitFlags -> m String -> m String+getCategory flags = fromFlagOrPrompt (category flags)++-- | Try to guess extra source files (don't prompt the user).+getExtraSrcFiles :: Interactive m => InitFlags -> m (Set String)+getExtraSrcFiles = pure . flagElim mempty Set.fromList . extraSrc++-- | Try to guess extra source files (don't prompt the user).+getExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set String))+getExtraDocFiles = pure+  . Just+  . flagElim (Set.singleton defaultChangelog) Set.fromList+  . extraDoc++-- | Ask whether the project builds a library or executable.+getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType+getPackageType InitFlags+  { initializeTestSuite = Flag True+  , packageType         = NoFlag+  } _ = return TestSuite+getPackageType flags act = fromFlagOrPrompt (packageType flags) act++getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath+getMainFile flags act = case mainIs flags of+    Flag a+      | isHsFilePath a -> return $ toHsFilePath a+      | otherwise -> act+    NoFlag -> act++getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool+getInitializeTestSuite flags = fromFlagOrPrompt (initializeTestSuite flags)++getTestDirs :: Interactive m => InitFlags -> m [String] -> m [String]+getTestDirs flags = fromFlagOrPrompt (testDirs flags)++-- | Ask for the Haskell base language of the package.+getLanguage :: Interactive m => InitFlags -> m Language -> m Language+getLanguage flags = fromFlagOrPrompt (language flags)++-- | Ask whether to generate explanatory comments.+getNoComments :: Interactive m => InitFlags -> m Bool -> m Bool+getNoComments flags = fromFlagOrPrompt (noComments flags)++-- | Ask for the application root directory.+getAppDirs :: Interactive m => InitFlags -> m [String] -> m [String]+getAppDirs flags = fromFlagOrPrompt (applicationDirs flags)++-- | Ask for the source (library) root directory.+getSrcDirs :: Interactive m => InitFlags -> m [String] -> m [String]+getSrcDirs flags = fromFlagOrPrompt (sourceDirs flags)++-- | Retrieve the list of exposed modules+getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName)+getExposedModules = return+    . fromMaybe (myLibModule NEL.:| [])+    . join+    . flagToMaybe+    . fmap NEL.nonEmpty+    . exposedModules++-- | Retrieve the list of other modules+getOtherModules :: Interactive m => InitFlags -> m [ModuleName]+getOtherModules = return . fromFlagOrDefault [] . otherModules++-- | Retrieve the list of build tools+getBuildTools :: Interactive m => InitFlags -> m [Dependency]+getBuildTools = flagElim (return []) (foldM go []) . buildTools+  where+    go acc dep = case eitherParsec dep of+      Left e -> do+        putStrLn $ "Failed to parse dependency: " ++ e+        putStrLn "Skipping..."++        return acc+      Right d -> return $ acc ++ [d]++-- | Retrieve the list of dependencies+getDependencies+    :: Interactive m+    => InitFlags+    -> m [Dependency]+    -> m [Dependency]+getDependencies flags = fromFlagOrPrompt (dependencies flags)+++-- | Retrieve the list of extensions+getOtherExts :: Interactive m => InitFlags -> m [Extension]+getOtherExts = return . fromFlagOrDefault [] .  otherExts++-- | Tell whether to overwrite files on write+--+getOverwrite :: Interactive m => InitFlags -> m Bool+getOverwrite = return . fromFlagOrDefault False .  overwrite++-- -------------------------------------------------------------------- --+-- Shared prompts++simpleProjectPrompt :: Interactive m => InitFlags -> m Bool+simpleProjectPrompt flags = getSimpleProject flags $+    promptYesNo+      "Should I generate a simple project with sensible defaults"+      (DefaultPrompt True)++initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool+initializeTestSuitePrompt flags = getInitializeTestSuite flags $+    promptYesNo+      "Should I generate a test suite for the library"+      (DefaultPrompt True)++packageTypePrompt :: Interactive m => InitFlags -> m PackageType+packageTypePrompt flags = getPackageType flags $ do+    pt <- promptList "What does the package build"+      packageTypes+      (DefaultPrompt "Executable")+      Nothing+      False++    return $ fromMaybe Executable (parsePackageType pt)+  where+    packageTypes =+      [ "Library"+      , "Executable"+      , "Library and Executable"+      , "Test suite"+      ]++    parsePackageType = \case+      "Library" -> Just Library+      "Executable" -> Just Executable+      "Library and Executable" -> Just LibraryAndExecutable+      "Test suite" -> Just TestSuite+      _ -> Nothing++testMainPrompt :: Interactive m => m HsFilePath+testMainPrompt = do+    fp <- promptList "What is the main module of the test suite?"+      [defaultMainIs', "Main.lhs"]+      (DefaultPrompt defaultMainIs')+      Nothing+      True++    let hs = toHsFilePath fp++    case _hsFileType hs of+      InvalidHsPath -> do+        putStrLn $ concat+          [ "Main file "+          , show hs+          , " is not a valid haskell file. Source files must end in .hs or .lhs."+          ]+        testMainPrompt+      _ -> return hs+  where+    defaultMainIs' = show defaultMainIs++dependenciesPrompt+    :: Interactive m+    => InstalledPackageIndex+    -> InitFlags+    -> m [Dependency]+dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags)++-- -------------------------------------------------------------------- --+-- utilities++-- | If a flag is defined, return its value or else execute+-- an interactive action.+--+fromFlagOrPrompt+    :: Interactive m+    => Flag a+    -> m a+    -> m a+fromFlagOrPrompt flag action = flagElim action return flag
+ src/Distribution/Client/Init/Format.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      :  Distribution.Client.Init.Format+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Pretty printing and field formatting utilities used for file creation.+--+module Distribution.Client.Init.Format+( -- * cabal file formatters+  listFieldS+, field+, fieldD+, commentedOutWithComments+, withComments+, annNoComments+, postProcessFieldLines+  -- * stanza generation+, mkCommonStanza+, mkLibStanza+, mkExeStanza+, mkTestStanza+, mkPkgDescription+) where+++import Distribution.Pretty+import Distribution.Fields+import Distribution.Client.Init.Types+import Distribution.License+import Text.PrettyPrint+import Distribution.Solver.Compat.Prelude hiding (empty)+import Distribution.PackageDescription.FieldGrammar+import Distribution.Simple.Utils hiding (cabalVersion)+import Distribution.Utils.Path+import Distribution.Package (unPackageName)+import qualified Distribution.SPDX.License as SPDX+import Distribution.CabalSpecVersion+import Distribution.FieldGrammar.Newtypes (SpecLicense(SpecLicense))+++-- | Construct a 'PrettyField' from a field that can be automatically+--   converted to a 'Doc' via 'display'.+field+    :: Pretty b+    => FieldName+    -> (a -> b)+    -> a+    -> [String]+    -> Bool+    -> WriteOpts+    -> PrettyField FieldAnnotation+field fieldName modifier fieldContents =+    fieldD fieldName (pretty $ modifier fieldContents)++-- | Construct a 'PrettyField' from a 'Doc' Flag.+fieldD+    :: FieldName -- ^ Name of the field+    -> Doc       -- ^ Field contents+    -> [String]  -- ^ Comment to explain the field+    -> Bool      -- ^ Should the field be included (commented out) even if blank?+    -> WriteOpts+    -> PrettyField FieldAnnotation+fieldD fieldName fieldContents fieldComments includeField opts+      -- If the "--no-comments" or "--minimal" flag is set, strip comments.+    | hasNoComments || isMinimal = contents NoComment+    | otherwise                  = contents $ commentPositionFor fieldName fieldComments+  where+    commentPositionFor fn+      | fn == "cabal-version" = CommentAfter+      | otherwise = CommentBefore++    isMinimal = _optMinimal opts+    hasNoComments = _optNoComments opts++    contents+        -- If there is no content, optionally produce a commented out field.+      | fieldContents == empty = fieldSEmptyContents+      | otherwise              = fieldSWithContents++    fieldSEmptyContents cs+      | not includeField || isMinimal = PrettyEmpty+      | otherwise = PrettyField+        (commentedOutWithComments cs)+        fieldName+        empty++    fieldSWithContents cs =+      PrettyField (withComments cs) fieldName fieldContents+++-- | A field annotation instructing the pretty printer to comment out the field+--   and any contents, with no comments.+commentedOutWithComments :: CommentPosition -> FieldAnnotation+commentedOutWithComments (CommentBefore cs) = FieldAnnotation True . CommentBefore $ map commentNoTrailing cs+commentedOutWithComments (CommentAfter  cs) = FieldAnnotation True . CommentAfter  $ map commentNoTrailing cs+commentedOutWithComments NoComment = FieldAnnotation True NoComment++-- | A field annotation with the specified comment lines.+withComments :: CommentPosition -> FieldAnnotation+withComments (CommentBefore cs) = FieldAnnotation False . CommentBefore $ map commentNoTrailing cs+withComments (CommentAfter  cs) = FieldAnnotation False . CommentAfter  $ map commentNoTrailing cs+withComments NoComment = FieldAnnotation False NoComment++-- | A field annotation with no comments.+annNoComments :: FieldAnnotation+annNoComments = FieldAnnotation False NoComment++postProcessFieldLines :: FieldAnnotation -> [String] -> [String]+postProcessFieldLines ann+  | annCommentedOut ann = fmap commentNoTrailing+  | otherwise = id++-- -------------------------------------------------------------------- --+-- Stanzas++-- The common stanzas are hardcoded for simplicity purposes,+-- see https://github.com/haskell/cabal/pull/7558#discussion_r693173846+mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation+mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of+  NoCommonStanzas -> PrettyEmpty+  _ -> PrettySection +    annNoComments+    "common"+    [text "warnings"]+    [field "ghc-options" text "-Wall" [] False opts]++mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation+mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) =+  PrettySection annNoComments (toUTF8BS "library") []+    [ case specHasCommonStanzas $ _optCabalSpec opts of+        NoCommonStanzas -> PrettyEmpty+        _ -> field "import" (hsep . map text) ["warnings"]+          ["Import common warning flags."]+          False +          opts++    , field "exposed-modules" formatExposedModules (toList expMods)+      ["Modules exported by the library."]+      True+      opts++    , field "other-modules" formatOtherModules otherMods+      ["Modules included in this library but not exported."]+      True+      opts++    , field "other-extensions" formatOtherExtensions exts+      ["LANGUAGE extensions used by modules in this package."]+      True+      opts++    , field "build-depends" formatDependencyList deps+      ["Other library packages from which modules are imported."]+      True+      opts++    , field "hs-source-dirs" formatHsSourceDirs (unsafeMakeSymbolicPath <$> srcDirs)+      ["Directories containing source files."]+      True+      opts++    , field (buildToolTag opts) formatDependencyList tools+      ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+      False+      opts++    , field "default-language" id lang+      ["Base language which the package is written in."]+      True+      opts+    ]++mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation+mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) =+    PrettySection annNoComments (toUTF8BS "executable") [exeName]+      [ case specHasCommonStanzas $ _optCabalSpec opts of+          NoCommonStanzas -> PrettyEmpty+          _ -> field "import" (hsep . map text) ["warnings"]+            ["Import common warning flags."]+            False +            opts+      +      , field "main-is" unsafeFromHs exeMain+         [".hs or .lhs file containing the Main module."]+         True+        opts++      , field "other-modules" formatOtherModules otherMods+        [ "Modules included in this executable, other than Main." ]+        True+        opts++      , field "other-extensions" formatOtherExtensions exts+        ["LANGUAGE extensions used by modules in this package."]+        True+        opts+      , field "build-depends" formatDependencyList deps+        ["Other library packages from which modules are imported."]+        True+        opts++      , field "hs-source-dirs" formatHsSourceDirs+        (unsafeMakeSymbolicPath <$> appDirs)+        ["Directories containing source files."]+        True+        opts++      , field (buildToolTag opts) formatDependencyList tools+        ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+        False+        opts++      , field "default-language" id lang+        ["Base language which the package is written in."]+        True+        opts+      ]+    where+      exeName = pretty $ _optPkgName opts++mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation+mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) =+    PrettySection annNoComments (toUTF8BS "test-suite") [suiteName]+       [ case specHasCommonStanzas $ _optCabalSpec opts of+           NoCommonStanzas -> PrettyEmpty+           _ -> field "import" (hsep . map text) ["warnings"]+             ["Import common warning flags."]+             False +             opts+      +       , field "default-language" id lang+         ["Base language which the package is written in."]+         True+         opts+       , field "other-modules" formatOtherModules otherMods+         [ "Modules included in this executable, other than Main." ]+         True+         opts++       , field "other-extensions" formatOtherExtensions exts+         ["LANGUAGE extensions used by modules in this package."]+         True+         opts++       , field "type" text "exitcode-stdio-1.0"+         ["The interface type and version of the test suite."]+         True+         opts++       , field "hs-source-dirs" formatHsSourceDirs+         (unsafeMakeSymbolicPath <$> dirs)+         ["Directories containing source files."]+         True+         opts++       , field "main-is" unsafeFromHs testMain+         ["The entrypoint to the test suite."]+         True+         opts++       , field  "build-depends" formatDependencyList deps+         ["Test dependencies."]+         True+         opts++       , field (buildToolTag opts) formatDependencyList tools+         ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+         False+         opts+       ]+     where+       suiteName = text $ unPackageName (_optPkgName opts) ++ "-test"++mkPkgDescription :: WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation]+mkPkgDescription opts pkgDesc =+    [ field "cabal-version" text (showCabalSpecVersion cabalSpec)+      [ "The cabal-version field refers to the version of the .cabal specification,"+      , "and can be different from the cabal-install (the tool) version and the"+      , "Cabal (the library) version you are using. As such, the Cabal (the library)"+      , "version used must be equal or greater than the version stated in this field."+      , "Starting from the specification version 2.2, the cabal-version field must be"+      , "the first thing in the cabal file."+      ]+      False+      opts++    , field "name" pretty (_pkgName pkgDesc)+      ["Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by"+      , "'cabal init'. For further documentation, see:"+      , "  http://haskell.org/cabal/users-guide/"+      , ""+      , "The name of the package."+      ]+      True+      opts++    , field  "version" pretty (_pkgVersion pkgDesc)+             ["The package version.",+              "See the Haskell package versioning policy (PVP) for standards",+              "guiding when and how versions should be incremented.",+              "https://pvp.haskell.org",+              "PVP summary:     +-+------- breaking API changes",+              "                 | | +----- non-breaking API additions",+              "                 | | | +--- code changes with no API change"]+      True+      opts++    , field "synopsis" text (_pkgSynopsis pkgDesc)+      ["A short (one-line) description of the package."]+      True+      opts++    , field "description" text ""+      ["A longer description of the package."]+      True+      opts++    , field "homepage" text (_pkgHomePage pkgDesc)+      ["URL for the project homepage or repository."]+      False+      opts++    , field "bug-reports" text ""+      ["A URL where users can report bugs."]+      False+      opts++    , field "license" pretty (_pkgLicense pkgDesc)+      ["The license under which the package is released."]+      True+      opts++    , case _pkgLicense pkgDesc of+        SpecLicense (Left  SPDX.NONE)          -> PrettyEmpty+        SpecLicense (Right AllRightsReserved)  -> PrettyEmpty+        SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty+        _ -> field "license-file" text "LICENSE"+             ["The file containing the license text."]+             False+             opts++    , field "author" text (_pkgAuthor pkgDesc)+      ["The package author(s)."]+      True+      opts++    , field "maintainer" text (_pkgEmail pkgDesc)+      ["An email address to which users can send suggestions, bug reports, and patches."]+      True+      opts++    , field "copyright" text ""+      ["A copyright notice."]+      True+      opts++    , field "category" text (_pkgCategory pkgDesc)+      []+      False+      opts+    , field "build-type" text "Simple"+      []+      False+      opts+    , case _pkgExtraDocFiles pkgDesc of+        Nothing -> PrettyEmpty+        Just fs ->+          field "extra-doc-files" formatExtraSourceFiles  (toList fs)+          ["Extra doc files to be distributed with the package, such as a CHANGELOG or a README."]+          True+          opts++    , field "extra-source-files" formatExtraSourceFiles (toList $ _pkgExtraSrcFiles pkgDesc)+      ["Extra source files to be distributed with the package, such as examples, or a tutorial module."]+      True+      opts+    ]+  where+    cabalSpec = _pkgCabalVersion pkgDesc++-- -------------------------------------------------------------------- --+-- Utils++listFieldS :: [String] -> Doc+listFieldS = text . intercalate ", "++unsafeFromHs :: HsFilePath -> Doc+unsafeFromHs = text . _hsFilePath++buildToolTag :: WriteOpts -> FieldName+buildToolTag opts+  | _optCabalSpec opts < CabalSpecV3_0 = "build-tools"+  | otherwise = "build-tool-depends"++commentNoTrailing :: String -> String+commentNoTrailing "" = "--"+commentNoTrailing c  = "-- " ++ c
− src/Distribution/Client/Init/Heuristics.hs 
@@ -1,396 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Heuristics--- Copyright   :  (c) Benedikt Huber 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Heuristics for creating initial cabal files.----------------------------------------------------------------------------------module Distribution.Client.Init.Heuristics (-    guessPackageName,-    scanForModules,     SourceFileEntry(..),-    neededBuildPrograms,-    guessMainFileCandidates,-    guessAuthorNameMail,-    knownCategories,-) where--import Prelude ()-import qualified Data.ByteString as BS-import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic (safeHead, safeTail, safeLast)--import Distribution.Simple.Setup (Flag(..), flagToMaybe)-import Distribution.Simple.Utils (fromUTF8BS)-import Distribution.ModuleName-    ( ModuleName, toFilePath )-import qualified Distribution.Package as P-import qualified Distribution.PackageDescription as PD-    ( category, packageDescription )-import Distribution.Client.Utils-         ( tryCanonicalizePath )-import Language.Haskell.Extension ( Extension )--import Distribution.Solver.Types.PackageIndex-    ( allPackagesByName )-import Distribution.Solver.Types.SourcePackage-    ( srcpkgDescription )--import Distribution.Client.Types ( SourcePackageDb(..) )-import Data.Char   ( isLower )-import Data.List   ( isInfixOf )-import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getCurrentDirectory, getDirectoryContents,-                          doesDirectoryExist, doesFileExist, getHomeDirectory, )-import Distribution.Compat.Environment ( getEnvironment )-import System.FilePath ( takeExtension, takeBaseName, dropExtension,-                         (</>), (<.>), splitDirectories, makeRelative )--import Distribution.Client.Init.Types     ( InitFlags(..) )-import Distribution.Client.Compat.Process ( readProcessWithExitCode )--import qualified Distribution.Utils.ShortText as ShortText---- | Return a list of candidate main files for this executable: top-level--- modules including the word 'Main' in the file name. The list is sorted in--- order of preference, shorter file names are preferred. 'Right's are existing--- candidates and 'Left's are those that do not yet exist.-guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath]-guessMainFileCandidates flags = do-  dir <--    maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  files <- getDirectoryContents dir-  let existingCandidates = filter isMain files-      -- We always want to give the user at least one default choice.  If either-      -- Main.hs or Main.lhs has already been created, then we don't want to-      -- suggest the other; however, if neither has been created, then we-      -- suggest both.-      newCandidates =-        if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"]-        then []-        else ["Main.hs", "Main.lhs"]-      candidates =-        sortBy (\x y -> comparing (length . either id id) x y-                        `mappend` compare x y)-               (map Left newCandidates ++ map Right existingCandidates)-  return candidates--  where-    isMain f =    (isInfixOf "Main" f || isInfixOf  "main" f)-               && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f)---- | Guess the package name based on the given root directory.-guessPackageName :: FilePath -> IO P.PackageName-guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)-                 . tryCanonicalizePath-  where-    -- Treat each span of non-alphanumeric characters as a hyphen. Each-    -- hyphenated component of a package name must contain at least one-    -- alphabetic character. An arbitrary character ('x') will be prepended if-    -- this is not the case for the first component, and subsequent components-    -- will simply be run together. For example, "1+2_foo-3" will become-    -- "x12-foo3".-    repair = repair' ('x' :) id-    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of-        "" -> repairComponent ""-        x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'-              in c ++ repairRest r-      where-        repairComponent c | all isDigit c = invalid c-                          | otherwise     = valid c-    repairRest = repair' id ('-' :)---- |Data type of source files found in the working directory-data SourceFileEntry = SourceFileEntry-    { relativeSourcePath :: FilePath-    , moduleName         :: ModuleName-    , fileExtension      :: String-    , imports            :: [ModuleName]-    , extensions         :: [Extension]-    } deriving Show--sfToFileName :: FilePath -> SourceFileEntry -> FilePath-sfToFileName projectRoot (SourceFileEntry relPath m ext _ _)-  = projectRoot </> relPath </> toFilePath m <.> ext---- |Search for source files in the given directory--- and return pairs of guessed Haskell source path and--- module names.-scanForModules :: FilePath -> IO [SourceFileEntry]-scanForModules rootDir = scanForModulesIn rootDir rootDir--scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]-scanForModulesIn projectRoot srcRoot = scan srcRoot []-  where-    scan dir hierarchy = do-        entries <- getDirectoryContents (projectRoot </> dir)-        (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries)-        let modules = catMaybes [ guessModuleName hierarchy file-                                | file <- files-                                , maybe False isUpper (safeHead file) ]-        modules' <- traverse (findImportsAndExts projectRoot) modules-        recMods <- traverse (scanRecursive dir hierarchy) dirs-        return $ concat (modules' : recMods)-    tagIsDir parent entry = do-        isDir <- doesDirectoryExist (parent </> entry)-        return $ (if isDir then Right else Left) entry-    guessModuleName hierarchy entry-        | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions   =-            SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure []-        | otherwise = Nothing-      where-        relRoot       = makeRelative projectRoot srcRoot-        unqualModName = dropExtension entry-        modName       = simpleParsec-                      $ intercalate "." . reverse $ (unqualModName : hierarchy)-        ext           = case takeExtension entry of '.':e -> e; e -> e-    scanRecursive parent hierarchy entry-      | maybe False isUpper (safeHead entry) = scan (parent </> entry) (entry : hierarchy)-      | maybe False isLower (safeHead entry) && not (ignoreDir entry) =-          scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy))-      | otherwise = return []-    ignoreDir ('.':_)  = True-    ignoreDir dir      = dir `elem` ["dist", "_darcs"]---- | Read the contents of the handle and parse for Language pragmas--- and other module names that might be part of this project.-findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry-findImportsAndExts projectRoot sf = do-  s <- fromUTF8BS <$> BS.readFile (sfToFileName projectRoot sf)--  let modules = mapMaybe-                ( getModName-                . drop 1-                . filter (not . null)-                . dropWhile (/= "import")-                . words-                )-              . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering-              . lines-              $ s--      -- TODO: We should probably make a better attempt at parsing-      -- comments above.  Unfortunately we can't use a full-fledged-      -- Haskell parser since cabal's dependencies must be kept at a-      -- minimum.--      -- A poor man's LANGUAGE pragma parser.-      exts = mapMaybe simpleParsec-           . concatMap getPragmas-           . filter isLANGUAGEPragma-           . map fst-           . drop 1-           . takeWhile (not . null . snd)-           . iterate (takeBraces . snd)-           $ ("",s)--      takeBraces = break (== '}') . dropWhile (/= '{')--      isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`)--      getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13--      splitCommas "" = []-      splitCommas xs = x : splitCommas (drop 1 y)-        where (x,y) = break (==',') xs--  return sf { imports    = modules-            , extensions = exts-            }-- where getModName :: [String] -> Maybe ModuleName-       getModName []               = Nothing-       getModName ("qualified":ws) = getModName ws-       getModName (ms:_)           = simpleParsec ms------ Unfortunately we cannot use the version exported by Distribution.Simple.Program-knownSuffixHandlers :: [(String,String)]-knownSuffixHandlers =-  [ ("gc",     "greencard")-  , ("chs",    "chs")-  , ("hsc",    "hsc2hs")-  , ("x",      "alex")-  , ("y",      "happy")-  , ("ly",     "happy")-  , ("cpphs",  "cpp")-  ]--sourceExtensions :: [String]-sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers--neededBuildPrograms :: [SourceFileEntry] -> [String]-neededBuildPrograms entries =-    [ handler-    | ext <- nubSet (map fileExtension entries)-    , handler <- maybeToList (lookup ext knownSuffixHandlers)-    ]---- | Guess author and email using darcs and git configuration options. Use--- the following in decreasing order of preference:------ 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)--- 2. Local repo configs--- 3. Global vcs configs--- 4. The generic $EMAIL------ Name and email are processed separately, so the guess might end up being--- a name from DARCS_EMAIL and an email from git config.------ Darcs has preference, for tradition's sake.-guessAuthorNameMail :: IO (Flag String, Flag String)-guessAuthorNameMail = fmap authorGuessPure authorGuessIO---- Ordered in increasing preference, since Flag-as-monoid is identical to--- Last.-authorGuessPure :: AuthorGuessIO -> AuthorGuess-authorGuessPure (AuthorGuessIO { authorGuessEnv = env-                               , authorGuessLocalDarcs = darcsLocalF-                               , authorGuessGlobalDarcs = darcsGlobalF-                               , authorGuessLocalGit = gitLocal-                               , authorGuessGlobalGit = gitGlobal })-    = mconcat-        [ emailEnv env-        , gitGlobal-        , darcsCfg darcsGlobalF-        , gitLocal-        , darcsCfg darcsLocalF-        , gitEnv env-        , darcsEnv env-        ]--authorGuessIO :: IO AuthorGuessIO-authorGuessIO = AuthorGuessIO-    <$> getEnvironment-    <*> (maybeReadFile $ "_darcs" </> "prefs" </> "author")-    <*> (maybeReadFile =<< liftM (</> (".darcs" </> "author")) getHomeDirectory)-    <*> gitCfg Local-    <*> gitCfg Global---- Types and functions used for guessing the author are now defined:--type AuthorGuess   = (Flag String, Flag String)-type Enviro        = [(String, String)]-data GitLoc        = Local | Global-data AuthorGuessIO = AuthorGuessIO {-    authorGuessEnv         :: Enviro,         -- ^ Environment lookup table-    authorGuessLocalDarcs  :: (Maybe String), -- ^ Contents of local darcs author info-    authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info-    authorGuessLocalGit    :: AuthorGuess,   -- ^ Git config --local-    authorGuessGlobalGit   :: AuthorGuess    -- ^ Git config --global-  }--darcsEnv :: Enviro -> AuthorGuess-darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"--gitEnv :: Enviro -> AuthorGuess-gitEnv env = (name, mail)-  where-    name = maybeFlag "GIT_AUTHOR_NAME" env-    mail = maybeFlag "GIT_AUTHOR_EMAIL" env--darcsCfg :: Maybe String -> AuthorGuess-darcsCfg = maybe mempty nameAndMail--emailEnv :: Enviro -> AuthorGuess-emailEnv env = (mempty, mail)-  where-    mail = maybeFlag "EMAIL" env--gitCfg :: GitLoc -> IO AuthorGuess-gitCfg which = do-  name <- gitVar which "user.name"-  mail <- gitVar which "user.email"-  return (name, mail)--gitVar :: GitLoc -> String -> IO (Flag String)-gitVar which = fmap happyOutput . gitConfigQuery which--happyOutput :: (ExitCode, a, t) -> Flag a-happyOutput v = case v of-  (ExitSuccess, s, _) -> Flag s-  _                   -> mempty--gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)-gitConfigQuery which key =-    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""-  where-    w = case which of-        Local  -> "--local"-        Global -> "--global"-    trim' (a, b, c) = (a, trim b, c)--maybeFlag :: String -> Enviro -> Flag String-maybeFlag k = maybe mempty Flag . lookup k---- | Read the first non-comment, non-trivial line of a file, if it exists-maybeReadFile :: String -> IO (Maybe String)-maybeReadFile f = do-    exists <- doesFileExist f-    if exists-        then fmap getFirstLine $ readFile f-        else return Nothing-  where-    getFirstLine content =-      let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content-      in case nontrivialLines of-           [] -> Nothing-           (l:_) -> Just l---- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached-knownCategories :: SourcePackageDb -> [String]-knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet-    [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex)-          , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg-          , cat <- splitString ',' $ ShortText.fromShortText catList-    ]---- Parse name and email, from darcs pref files or environment variable-nameAndMail :: String -> (Flag String, Flag String)-nameAndMail str-  | all isSpace nameOrEmail = mempty-  | null erest = (mempty, Flag $ trim nameOrEmail)-  | otherwise  = (Flag $ trim nameOrEmail, Flag mail)-  where-    (nameOrEmail,erest) = break (== '<') str-    (mail,_)            = break (== '>') (safeTail erest)--trim :: String -> String-trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse-  where-    removeLeadingSpace  = dropWhile isSpace---- split string at given character, and remove whitespace-splitString :: Char -> String -> [String]-splitString sep str = go str where-    go s = if null s' then [] else tok : go rest where-      s' = dropWhile (\c -> c == sep || isSpace c) s-      (tok,rest) = break (==sep) s'--nubSet :: (Ord a) => [a] -> [a]-nubSet = Set.toList . Set.fromList--{--test db testProjectRoot = do-  putStrLn "Guessed package name"-  (guessPackageName >=> print) testProjectRoot-  putStrLn "Guessed name and email"-  guessAuthorNameMail >>= print--  mods <- scanForModules testProjectRoot--  putStrLn "Guessed modules"-  mapM_ print mods-  putStrLn "Needed build programs"-  print (neededBuildPrograms mods)--  putStrLn "List of known categories"-  print $ knownCategories db--}
+ src/Distribution/Client/Init/Interactive/Command.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE LambdaCase, MultiWayIf #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Command+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Interactive.Command+( -- * Commands+  createProject+  -- ** Target generation+, genPkgDescription+, genLibTarget+, genExeTarget+, genTestTarget+  -- ** Prompts+, cabalVersionPrompt+, packageNamePrompt+, versionPrompt+, licensePrompt+, authorPrompt+, emailPrompt+, homepagePrompt+, synopsisPrompt+, categoryPrompt+, mainFilePrompt+, testDirsPrompt+, languagePrompt+, noCommentsPrompt+, appDirsPrompt+, dependenciesPrompt+, srcDirsPrompt+) where+++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last)++import Distribution.CabalSpecVersion (CabalSpecVersion(..), showCabalSpecVersion)+import Distribution.Version (Version)+import Distribution.Types.PackageName (PackageName, unPackageName)+import qualified Distribution.SPDX as SPDX+import Distribution.Client.Init.Defaults+import Distribution.Client.Init.FlagExtractors+import Distribution.Client.Init.Prompt+import Distribution.Client.Init.Types+import Distribution.Client.Init.Utils+import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorName, guessAuthorEmail)+import Distribution.FieldGrammar.Newtypes (SpecLicense(..))+import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault)+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Client.Types (SourcePackageDb(..))+import Distribution.Solver.Types.PackageIndex (elemByPackageName)++import Language.Haskell.Extension (Language(..))+import Distribution.License (knownLicenses)+import Distribution.Parsec (simpleParsec')+++-- | Main driver for interactive prompt code.+--+createProject+    :: Interactive m+    => Verbosity+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> InitFlags+    -> m ProjectSettings+createProject v pkgIx srcDb initFlags = do++  -- The workflow is as follows:+  --+  --  1. Get the package type, supplied as either a program input or+  --     via user prompt. This determines what targets will be built+  --     in later steps.+  --+  --  2. Generate package description and the targets specified by+  --     the package type. Once this is done, a prompt for building+  --     test suites is initiated, and this determines if we build+  --     test targets as well. Then we ask if the user wants to+  --     comment their .cabal file with pretty comments.+  --+  --  3. The targets are passed to the file creator script, and associated+  --     directories/files/modules are created, with the a .cabal file+  --     being generated as a final result.+  --++  pkgType <- packageTypePrompt initFlags+  isMinimal <- getMinimal initFlags+  doOverwrite <- overwritePrompt initFlags+  pkgDir <- getPackageDir initFlags+  pkgDesc <- fixupDocFiles v =<< genPkgDescription initFlags srcDb++  let pkgName = _pkgName pkgDesc+      cabalSpec = _pkgCabalVersion pkgDesc+      mkOpts cs = WriteOpts+        doOverwrite isMinimal cs+        v pkgDir pkgType pkgName+      initFlags' = initFlags { cabalVersion = Flag cabalSpec }++  case pkgType of+    Library -> do+      libTarget <- genLibTarget initFlags' pkgIx+      testTarget <- addLibDepToTest pkgName <$>+        genTestTarget initFlags' pkgIx++      comments <- noCommentsPrompt initFlags'++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc+        (Just libTarget) Nothing testTarget++    Executable -> do+      exeTarget <- genExeTarget initFlags' pkgIx+      comments <- noCommentsPrompt initFlags'++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc Nothing+        (Just exeTarget) Nothing++    LibraryAndExecutable -> do+      libTarget <- genLibTarget initFlags' pkgIx++      exeTarget <- addLibDepToExe pkgName <$>+        genExeTarget initFlags' pkgIx++      testTarget <- addLibDepToTest pkgName <$>+        genTestTarget initFlags' pkgIx++      comments <- noCommentsPrompt initFlags'++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc (Just libTarget)+        (Just exeTarget) testTarget++    TestSuite -> do+      -- the line below is necessary because if both package type and test flags+      -- are *not* passed, the user will be prompted for a package type (which+      -- includes TestSuite in the list). It prevents that the user end up with a+      -- TestSuite target with initializeTestSuite set to NoFlag, thus avoiding the prompt.+      let initFlags'' = initFlags' { initializeTestSuite = Flag True }+      testTarget <- genTestTarget initFlags'' pkgIx++      comments <- noCommentsPrompt initFlags''++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc+        Nothing Nothing testTarget++-- -------------------------------------------------------------------- --+-- Target and pkg description generation++-- | Extract flags relevant to a package description and interactively+-- generate a 'PkgDescription' object for creation. If the user specifies+-- the generation of a simple package, then a simple target with defaults+-- is generated.+--+genPkgDescription+    :: Interactive m+    => InitFlags+    -> SourcePackageDb+    -> m PkgDescription+genPkgDescription flags' srcDb = do+  csv <- cabalVersionPrompt flags'+  let flags = flags' { cabalVersion = Flag csv }+  PkgDescription csv+    <$> packageNamePrompt srcDb flags+    <*> versionPrompt flags+    <*> licensePrompt flags+    <*> authorPrompt flags+    <*> emailPrompt flags+    <*> homepagePrompt flags+    <*> synopsisPrompt flags+    <*> categoryPrompt flags+    <*> getExtraSrcFiles flags+    <*> getExtraDocFiles flags++-- | Extract flags relevant to a library target and interactively+-- generate a 'LibTarget' object for creation. If the user specifies+-- the generation of a simple package, then a simple target with defaults+-- is generated.+--+genLibTarget+    :: Interactive m+    => InitFlags+    -> InstalledPackageIndex+    -> m LibTarget+genLibTarget flags pkgs = LibTarget+    <$> srcDirsPrompt flags+    <*> languagePrompt flags "library"+    <*> getExposedModules flags+    <*> getOtherModules flags+    <*> getOtherExts flags+    <*> dependenciesPrompt pkgs flags+    <*> getBuildTools flags++-- | Extract flags relevant to a executable target and interactively+-- generate a 'ExeTarget' object for creation. If the user specifies+-- the generation of a simple package, then a simple target with defaults+-- is generated.+--+genExeTarget+    :: Interactive m+    => InitFlags+    -> InstalledPackageIndex+    -> m ExeTarget+genExeTarget flags pkgs = ExeTarget+    <$> mainFilePrompt flags+    <*> appDirsPrompt flags+    <*> languagePrompt flags "executable"+    <*> getOtherModules flags+    <*> getOtherExts flags+    <*> dependenciesPrompt pkgs flags+    <*> getBuildTools flags++-- | Extract flags relevant to a test target and interactively+-- generate a 'TestTarget' object for creation. If the user specifies+-- the generation of a simple package, then a simple target with defaults+-- is generated.+--+-- Note: this workflow is only enabled if the user answers affirmatively+-- when prompted, or if the user passes in the flag to enable+-- test suites at command line.+--+genTestTarget+    :: Interactive m+    => InitFlags+    -> InstalledPackageIndex+    -> m (Maybe TestTarget)+genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go+  where+    go initialized+      | not initialized = return Nothing+      | otherwise = fmap Just $ TestTarget+        <$> testMainPrompt+        <*> testDirsPrompt flags+        <*> languagePrompt flags "test suite"+        <*> getOtherModules flags+        <*> getOtherExts flags+        <*> dependenciesPrompt pkgs flags+        <*> getBuildTools flags+++-- -------------------------------------------------------------------- --+-- Prompts++overwritePrompt :: Interactive m => InitFlags -> m Bool+overwritePrompt flags = do+  isOverwrite <- getOverwrite flags+  promptYesNo+    "Do you wish to overwrite existing files (backups will be created) (y/n)"+    (DefaultPrompt isOverwrite)++cabalVersionPrompt :: Interactive m => InitFlags -> m CabalSpecVersion+cabalVersionPrompt flags = getCabalVersion flags $ do+    v <- promptList "Please choose version of the Cabal specification to use"+      ppVersions+      (DefaultPrompt ppDefault)+      (Just takeVersion)+      False+    -- take just the version numbers for convenience+    return $ parseCabalVersion (takeVersion v)+  where+    -- only used when presenting the default in prompt+    takeVersion = takeWhile (/= ' ')++    ppDefault = displayCabalVersion defaultCabalVersion+    ppVersions = displayCabalVersion <$> defaultCabalVersions++    parseCabalVersion :: String -> CabalSpecVersion+    parseCabalVersion "1.24" = CabalSpecV1_24+    parseCabalVersion "2.0" = CabalSpecV2_0+    parseCabalVersion "2.2" = CabalSpecV2_2+    parseCabalVersion "2.4" = CabalSpecV2_4+    parseCabalVersion "3.0" = CabalSpecV3_0+    parseCabalVersion "3.4" = CabalSpecV3_4+    parseCabalVersion _ = defaultCabalVersion -- 2.4++    displayCabalVersion :: CabalSpecVersion -> String+    displayCabalVersion v = case v of+      CabalSpecV1_24 -> "1.24  (legacy)"+      CabalSpecV2_0  -> "2.0   (+ support for Backpack, internal sub-libs, '^>=' operator)"+      CabalSpecV2_2  -> "2.2   (+ support for 'common', 'elif', redundant commas, SPDX)"+      CabalSpecV2_4  -> "2.4   (+ support for '**' globbing)"+      CabalSpecV3_0  -> "3.0   (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"+      CabalSpecV3_4  -> "3.4   (+ sublibraries in 'mixins', optional 'default-language')"+      _ -> showCabalSpecVersion v++packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName+packageNamePrompt srcDb flags = getPackageName flags $ do+    defName <- case packageDir flags of+        Flag b -> return $ filePathToPkgName b+        NoFlag -> currentDirPkgName++    go $ DefaultPrompt defName+  where+    go defName = prompt "Package name" defName >>= \n ->+      if isPkgRegistered n+      then do+        don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True)+        if don'tUseName+        then go defName+        else return n+      else return n++    isPkgRegistered = elemByPackageName (packageIndex srcDb)++    inUseMsg pn = "The name "+      ++ unPackageName pn+      ++ " is already in use by another package on Hackage."++    promptOtherNameMsg pn = inUseMsg pn ++ " Do you want to choose a different name (y/n)"++versionPrompt :: Interactive m => InitFlags -> m Version+versionPrompt flags = getVersion flags go+  where+    go = do+      vv <- promptStr "Package version" (DefaultPrompt $ prettyShow defaultVersion)+      case simpleParsec vv of+        Nothing -> do+          putStrLn+            $ "Version must be a valid PVP format (e.g. 0.1.0.0): "+            ++ vv+          go+        Just v -> return v++licensePrompt :: Interactive m => InitFlags -> m SpecLicense+licensePrompt flags = getLicense flags $ do+    let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags)+    l <- promptList "Please choose a license"+      (licenses csv)+      MandatoryPrompt+      Nothing+      True++    case simpleParsec' csv l of+      Nothing -> do+        putStrLn ( "The license must be a valid SPDX expression:"+                ++ "\n - On the SPDX License List: https://spdx.org/licenses/"+                ++ "\n - NONE, if you do not want to grant any license"+                ++ "\n - LicenseRef-( alphanumeric | - | . )+"+                 )+        licensePrompt flags+      Just l' -> return l'+  where+    licenses csv = if csv >= CabalSpecV2_2+      then SPDX.licenseId <$> defaultLicenseIds+      else fmap prettyShow knownLicenses++authorPrompt :: Interactive m => InitFlags -> m String+authorPrompt flags = getAuthor flags $ do+    name <- guessAuthorName+    promptStr "Author name" (DefaultPrompt name)++emailPrompt :: Interactive m => InitFlags -> m String+emailPrompt flags = getEmail flags $ do+    email' <- guessAuthorEmail+    promptStr "Maintainer email" (DefaultPrompt email')++homepagePrompt :: Interactive m => InitFlags -> m String+homepagePrompt flags = getHomepage flags $+    promptStr "Project homepage URL" OptionalPrompt++synopsisPrompt :: Interactive m => InitFlags -> m String+synopsisPrompt flags = getSynopsis flags $+    promptStr "Project synopsis" OptionalPrompt++categoryPrompt :: Interactive m => InitFlags -> m String+categoryPrompt flags = getCategory flags $ promptList+      "Project category" defaultCategories+      (DefaultPrompt "") (Just matchNone) True+  where+    matchNone s+      | null s = "(none)"+      | otherwise = s++mainFilePrompt :: Interactive m => InitFlags -> m HsFilePath+mainFilePrompt flags = getMainFile flags go+  where+    defaultMainIs' = show defaultMainIs+    go = do+      fp <- promptList "What is the main module of the executable"+        [defaultMainIs', "Main.lhs"]+        (DefaultPrompt defaultMainIs')+        Nothing+        True++      let hs = toHsFilePath fp++      case _hsFileType hs of+        InvalidHsPath -> do+          putStrLn $ concat+            [ "Main file "+            , show hs+            , " is not a valid haskell file. Source files must end in .hs or .lhs."+            ]+          go++        _ -> return hs++testDirsPrompt :: Interactive m => InitFlags -> m [String]+testDirsPrompt flags = getTestDirs flags $ do+    dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir)+    return [dir]++languagePrompt :: Interactive m => InitFlags -> String -> m Language+languagePrompt flags pkgType = getLanguage flags $ do+    let h2010   = "Haskell2010"+        h98     = "Haskell98"+        ghc2021 = "GHC2021 (requires at least GHC 9.2)"+          +    l <- promptList ("Choose a language for your " ++ pkgType)+      [h2010, h98, ghc2021]+      (DefaultPrompt h2010)+      Nothing+      True++    if+      | l == h2010       -> return Haskell2010+      | l == h98         -> return Haskell98+      | l == ghc2021     -> return GHC2021+      | all isAlphaNum l -> return $ UnknownLanguage l+      | otherwise        -> do+        putStrLn+          $ "\nThe language must be alphanumeric. "+          ++ "Please enter a different language."++        languagePrompt flags pkgType++noCommentsPrompt :: Interactive m => InitFlags -> m Bool+noCommentsPrompt flags = getNoComments flags $ do+    doComments <- promptYesNo+      "Add informative comments to each field in the cabal file. (y/n)"+      (DefaultPrompt True)++    --+    -- if --no-comments is flagged, then we choose not to generate comments+    -- for fields in the cabal file, but it's a nicer UX to present the+    -- affirmative question which must be negated.+    --++    return (not doComments)++-- | Ask for the application root directory.+appDirsPrompt :: Interactive m => InitFlags -> m [String]+appDirsPrompt flags = getAppDirs flags $ do+    dir <- promptList promptMsg+      [defaultApplicationDir, "exe", "src-exe"]+      (DefaultPrompt defaultApplicationDir)+      Nothing+      True++    return [dir]+  where+    promptMsg = case mainIs flags of+      Flag p -> "Application (" ++ p ++ ") directory"+      NoFlag -> "Application directory"++-- | Ask for the source (library) root directory.+srcDirsPrompt :: Interactive m => InitFlags -> m [String]+srcDirsPrompt flags = getSrcDirs flags $ do+    dir <- promptList "Library source directory"+      [defaultSourceDir, "lib", "src-lib"]+      (DefaultPrompt defaultSourceDir)+      Nothing+      True++    return [dir]
+ src/Distribution/Client/Init/NonInteractive/Command.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE LambdaCase #-}+module Distribution.Client.Init.NonInteractive.Command+( genPkgDescription+, genLibTarget+, genExeTarget+, genTestTarget+, createProject+, packageTypeHeuristics+, authorHeuristics+, emailHeuristics+, cabalVersionHeuristics+, packageNameHeuristics+, versionHeuristics+, mainFileHeuristics+, testDirsHeuristics+, initializeTestSuiteHeuristics+, exposedModulesHeuristics+, libOtherModulesHeuristics+, exeOtherModulesHeuristics+, testOtherModulesHeuristics+, buildToolsHeuristics+, dependenciesHeuristics+, otherExtsHeuristics+, licenseHeuristics+, homepageHeuristics+, synopsisHeuristics+, categoryHeuristics+, extraDocFileHeuristics+, appDirsHeuristics+, srcDirsHeuristics+, languageHeuristics+, noCommentsHeuristics+, minimalHeuristics+, overwriteHeuristics+) where+import Distribution.Client.Init.Types++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last, head)++import Data.List (last, head)+import qualified Data.List.NonEmpty as NEL++import Distribution.CabalSpecVersion (CabalSpecVersion(..))+import Distribution.Version (Version)+import Distribution.ModuleName (ModuleName, components)+import Distribution.Types.Dependency (Dependency(..))+import Distribution.Types.PackageName (PackageName, unPackageName)+import Distribution.Client.Init.Defaults+import Distribution.Client.Init.NonInteractive.Heuristics+import Distribution.Client.Init.Utils+import Distribution.Client.Init.FlagExtractors+import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault)+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Client.Types (SourcePackageDb(..))+import Distribution.Solver.Types.PackageIndex (elemByPackageName)+import Distribution.Utils.Generic (safeHead)+import Distribution.Verbosity++import Language.Haskell.Extension (Language(..), Extension(..))++import System.FilePath (splitDirectories, (</>))+import Distribution.Simple.Compiler+import qualified Data.Set as Set+import Distribution.FieldGrammar.Newtypes+++-- | Main driver for interactive prompt code.+--+createProject+    :: Interactive m+    => Compiler+    -> Verbosity+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> InitFlags+    -> m ProjectSettings+createProject comp v pkgIx srcDb initFlags = do++  -- The workflow is as follows:+  --+  --  1. Get the package type, supplied as either a program input or+  --     via user prompt. This determines what targets will be built+  --     in later steps.+  --+  --  2. Determine whether we generate simple targets or prompt the+  --     user for inputs when not supplied as a flag. In general,+  --     flag inputs are preferred, and "simple" here means+  --     reasonable defaults defined in @Defaults.hs@.+  --+  --  3. Generate package description and the targets specified by+  --     the package type. Once this is done, a prompt for building+  --     test suites is initiated, and this determines if we build+  --     test targets as well. Then we ask if the user wants to+  --     comment their .cabal file with pretty comments.+  --+  --  4. The targets are passed to the file creator script, and associated+  --     directories/files/modules are created, with the a .cabal file+  --     being generated as a final result.+  --++  pkgType <- packageTypeHeuristics initFlags+  isMinimal <- getMinimal initFlags+  doOverwrite <- getOverwrite initFlags+  pkgDir <- packageDirHeuristics initFlags+  pkgDesc <- fixupDocFiles v =<< genPkgDescription initFlags srcDb+  comments <- noCommentsHeuristics initFlags++  let pkgName = _pkgName pkgDesc+      cabalSpec = _pkgCabalVersion pkgDesc+      mkOpts cs = WriteOpts+        doOverwrite isMinimal cs+        v pkgDir pkgType pkgName++  case pkgType of+    Library -> do+      libTarget <- genLibTarget initFlags comp pkgIx cabalSpec+      testTarget <- addLibDepToTest pkgName <$>+        genTestTarget initFlags comp pkgIx cabalSpec++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc+        (Just libTarget) Nothing testTarget++    Executable -> do+      exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc Nothing+        (Just exeTarget) Nothing++    LibraryAndExecutable -> do+      libTarget <- genLibTarget initFlags comp pkgIx cabalSpec+      exeTarget <- addLibDepToExe pkgName <$>+        genExeTarget initFlags comp pkgIx cabalSpec+      testTarget <- addLibDepToTest pkgName <$>+        genTestTarget initFlags comp pkgIx cabalSpec++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc (Just libTarget)+        (Just exeTarget) testTarget+    +    TestSuite -> do+      testTarget <- genTestTarget initFlags comp pkgIx cabalSpec++      return $ ProjectSettings+        (mkOpts comments cabalSpec) pkgDesc+        Nothing Nothing testTarget++genPkgDescription+  :: Interactive m+  => InitFlags+  -> SourcePackageDb+  -> m PkgDescription+genPkgDescription flags srcDb = PkgDescription+  <$> cabalVersionHeuristics flags+  <*> packageNameHeuristics srcDb flags+  <*> versionHeuristics flags+  <*> licenseHeuristics flags+  <*> authorHeuristics flags+  <*> emailHeuristics flags+  <*> homepageHeuristics flags+  <*> synopsisHeuristics flags+  <*> categoryHeuristics flags+  <*> getExtraSrcFiles flags+  <*> extraDocFileHeuristics flags++genLibTarget+  :: Interactive m+  => InitFlags+  -> Compiler+  -> InstalledPackageIndex+  -> CabalSpecVersion+  -> m LibTarget+genLibTarget flags comp pkgs v = do+  srcDirs   <- srcDirsHeuristics flags+  let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs+  LibTarget srcDirs+    <$> languageHeuristics flags comp+    <*> exposedModulesHeuristics flags+    <*> libOtherModulesHeuristics flags+    <*> otherExtsHeuristics flags srcDir+    <*> dependenciesHeuristics flags srcDir pkgs+    <*> buildToolsHeuristics flags srcDir v++genExeTarget+  :: Interactive m+  => InitFlags+  -> Compiler+  -> InstalledPackageIndex+  -> CabalSpecVersion+  -> m ExeTarget+genExeTarget flags comp pkgs v = do+  appDirs  <- appDirsHeuristics flags+  let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs+  ExeTarget+    <$> mainFileHeuristics flags+    <*> pure appDirs+    <*> languageHeuristics flags comp+    <*> exeOtherModulesHeuristics flags+    <*> otherExtsHeuristics flags appDir+    <*> dependenciesHeuristics flags appDir pkgs+    <*> buildToolsHeuristics flags appDir v++genTestTarget+  :: Interactive m+  => InitFlags+  -> Compiler+  -> InstalledPackageIndex+  -> CabalSpecVersion+  -> m (Maybe TestTarget)+genTestTarget flags comp pkgs v = do+  initialized <- initializeTestSuiteHeuristics flags+  testDirs' <- testDirsHeuristics flags+  let testDir = fromMaybe defaultTestDir $ safeHead testDirs'+  if not initialized+  then return Nothing+  else fmap Just $ TestTarget+    <$> testMainHeuristics flags+    <*> pure testDirs'+    <*> languageHeuristics flags comp+    <*> testOtherModulesHeuristics flags+    <*> otherExtsHeuristics flags testDir+    <*> dependenciesHeuristics flags testDir pkgs+    <*> buildToolsHeuristics flags testDir v++-- -------------------------------------------------------------------- --+-- Get flags from init config++minimalHeuristics :: Interactive m => InitFlags -> m Bool+minimalHeuristics = getMinimal++overwriteHeuristics :: Interactive m => InitFlags -> m Bool+overwriteHeuristics = getOverwrite++packageDirHeuristics :: Interactive m => InitFlags -> m FilePath+packageDirHeuristics = getPackageDir++-- | Get the version of the cabal spec to use.+--   The spec version can be specified by the InitFlags cabalVersion field. If+--   none is specified then the default version is used.+cabalVersionHeuristics :: Interactive m => InitFlags -> m CabalSpecVersion+cabalVersionHeuristics flags = getCabalVersion flags guessCabalSpecVersion++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+packageNameHeuristics :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName+packageNameHeuristics sourcePkgDb flags = getPackageName flags $ do+    defName <- guessPackageName =<< case packageDir flags of+      Flag a -> return a+      NoFlag -> last . splitDirectories <$> getCurrentDirectory++    when (isPkgRegistered defName)+      $ putStrLn (inUseMsg defName)++    return defName++  where+    isPkgRegistered = elemByPackageName (packageIndex sourcePkgDb)++    inUseMsg pn = "The name "+      ++ unPackageName pn+      ++ " is already in use by another package on Hackage."++-- | Package version: use 0.1.0.0 as a last resort+versionHeuristics :: Interactive m => InitFlags -> m Version+versionHeuristics flags = getVersion flags $ return defaultVersion++-- | Choose a license for the package.+-- The license can come from Initflags (license field), if it is not present+-- then prompt the user from a predefined list of licenses.+licenseHeuristics :: Interactive m => InitFlags -> m SpecLicense+licenseHeuristics flags = getLicense flags $ guessLicense flags++-- | The author's name. Prompt, or try to guess from an existing+--   darcs repo.+authorHeuristics :: Interactive m => InitFlags -> m String+authorHeuristics flags = getAuthor flags guessAuthorEmail++-- | The author's email. Prompt, or try to guess from an existing+--   darcs repo.+emailHeuristics :: Interactive m => InitFlags -> m String+emailHeuristics flags = getEmail flags guessAuthorName++-- | Prompt for a homepage URL for the package.+homepageHeuristics :: Interactive m => InitFlags -> m String+homepageHeuristics flags = getHomepage flags $ return ""++-- | Prompt for a project synopsis.+synopsisHeuristics :: Interactive m => InitFlags -> m String+synopsisHeuristics flags = getSynopsis flags $ return ""++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+categoryHeuristics :: Interactive m => InitFlags -> m String+categoryHeuristics flags = getCategory flags $ return ""++-- | Try to guess extra source files.+extraDocFileHeuristics :: Interactive m => InitFlags -> m (Maybe (Set FilePath))+extraDocFileHeuristics flags = case extraDoc flags of+  Flag x -> return $ Just $ Set.fromList x+  _ -> guessExtraDocFiles flags++-- | Try to guess if the project builds a library, an executable, or both.+packageTypeHeuristics :: Interactive m => InitFlags -> m PackageType+packageTypeHeuristics flags = getPackageType flags $ guessPackageType flags++-- | Try to guess the main file, if nothing is found, fallback+--   to a default value.+mainFileHeuristics :: Interactive m => InitFlags -> m HsFilePath+mainFileHeuristics flags = do+  appDir <- head <$> appDirsHeuristics flags+  getMainFile flags . guessMainFile $ appDir++testMainHeuristics :: Interactive m => InitFlags -> m HsFilePath+testMainHeuristics flags = do+  testDir <- head <$> testDirsHeuristics flags+  guessMainFile testDir++initializeTestSuiteHeuristics :: Interactive m => InitFlags -> m Bool+initializeTestSuiteHeuristics flags = getInitializeTestSuite flags $ return False++testDirsHeuristics :: Interactive m => InitFlags -> m [String]+testDirsHeuristics flags = getTestDirs flags $ return [defaultTestDir]++-- | Ask for the Haskell base language of the package.+languageHeuristics :: Interactive m => InitFlags -> Compiler -> m Language+languageHeuristics flags comp = getLanguage flags $ guessLanguage comp++-- | Ask whether to generate explanatory comments.+noCommentsHeuristics :: Interactive m => InitFlags -> m Bool+noCommentsHeuristics flags = getNoComments flags $ return False++-- | Ask for the application root directory.+appDirsHeuristics :: Interactive m => InitFlags -> m [String]+appDirsHeuristics flags = getAppDirs flags $ guessApplicationDirectories flags++-- | Ask for the source (library) root directory.+srcDirsHeuristics :: Interactive m => InitFlags -> m [String]+srcDirsHeuristics flags = getSrcDirs flags $ guessSourceDirectories flags++-- | Retrieve the list of exposed modules+exposedModulesHeuristics :: Interactive m => InitFlags -> m (NonEmpty ModuleName)+exposedModulesHeuristics flags = do+  mods <- case exposedModules flags of+    Flag x -> return x+    NoFlag -> do+      srcDir <- fromMaybe defaultSourceDir . safeHead <$> srcDirsHeuristics flags++      exists <- doesDirectoryExist srcDir++      if exists+        then do+          modules      <- filter isHaskell <$> listFilesRecursive srcDir+          modulesNames <- catMaybes <$> traverse retrieveModuleName modules++          otherModules' <- libOtherModulesHeuristics flags+          return $ filter (`notElem` otherModules') modulesNames+        +        else+          return []++  return $ if null mods+    then myLibModule NEL.:| []+    else NEL.fromList mods++-- | Retrieve the list of other modules for Libraries, filtering them+--   based on the last component of the module name+libOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName]+libOtherModulesHeuristics flags = case otherModules flags of+  Flag x -> return x+  NoFlag -> do+    let otherCandidates = ["Internal", "Utils"]+        srcDir = case sourceDirs flags of+          Flag x -> fromMaybe defaultSourceDir $ safeHead x+          NoFlag -> defaultSourceDir++    libDir <- (</> srcDir) <$> case packageDir flags of+      Flag x -> return x+      NoFlag -> getCurrentDirectory++    exists <- doesDirectoryExist libDir+    if exists+      then do+        otherModules' <- filter isHaskell <$> listFilesRecursive libDir+        filter ((`elem` otherCandidates) . last . components)+          . catMaybes <$> traverse retrieveModuleName otherModules'+      else return []++-- | Retrieve the list of other modules for Executables, it lists everything+--   that is a Haskell file within the application directory, excluding the main file+exeOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName]+exeOtherModulesHeuristics flags = case otherModules flags of+  Flag x -> return x+  NoFlag -> do+    let appDir = case applicationDirs flags of+          Flag x -> fromMaybe defaultApplicationDir $ safeHead x+          NoFlag -> defaultApplicationDir++    exeDir <- (</> appDir) <$> case packageDir flags of+      Flag x -> return x+      NoFlag -> getCurrentDirectory++    exists <- doesDirectoryExist exeDir+    if exists+      then do+        otherModules' <- filter (\f -> not (isMain f) && isHaskell f)+          <$> listFilesRecursive exeDir+        catMaybes <$> traverse retrieveModuleName otherModules'+      else return []++-- | Retrieve the list of other modules for Tests, it lists everything+--   that is a Haskell file within the tests directory, excluding the main file+testOtherModulesHeuristics :: Interactive m => InitFlags -> m [ModuleName]+testOtherModulesHeuristics flags = case otherModules flags of+  Flag x -> return x+  NoFlag -> do+    let testDir = case testDirs flags of+          Flag x -> fromMaybe defaultTestDir $ safeHead x+          NoFlag -> defaultTestDir++    testDir' <- (</> testDir) <$> case packageDir flags of+      Flag x -> return x+      NoFlag -> getCurrentDirectory++    exists <- doesDirectoryExist testDir'+    if exists+      then do+        otherModules' <- filter (\f -> not (isMain f) && isHaskell f)+          <$> listFilesRecursive testDir'+        catMaybes <$> traverse retrieveModuleName otherModules'+      else return []++-- | Retrieve the list of build tools+buildToolsHeuristics+    :: Interactive m+    => InitFlags+    -> FilePath+    -> CabalSpecVersion+    -> m [Dependency]+buildToolsHeuristics flags fp v = case buildTools flags of+  Flag{} -> getBuildTools flags+  NoFlag -> retrieveBuildTools v fp++-- | Retrieve the list of dependencies+dependenciesHeuristics :: Interactive m => InitFlags -> FilePath -> InstalledPackageIndex -> m [Dependency]+dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do+  sources <- retrieveSourceFiles fp++  let mods = case exposedModules flags of+        Flag x -> x+        NoFlag -> map moduleName sources++      groupedDeps  = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources+      filteredDeps = filter ((`notElem` mods) . snd) groupedDeps+      preludeNub   = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps++  retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx++-- | Retrieve the list of extensions+otherExtsHeuristics :: Interactive m => InitFlags -> FilePath -> m [Extension]+otherExtsHeuristics flags fp = case otherExts flags of+  Flag x -> return x+  NoFlag -> do+    exists <- doesDirectoryExist fp+    if exists+      then do+        sources     <- listFilesRecursive fp+        extensions' <- traverse retrieveModuleExtensions . filter isHaskell $ sources++        return $ nub . join $ extensions'+      else+        return []
+ src/Distribution/Client/Init/NonInteractive/Heuristics.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.NonInteractive.Heuristics+-- Copyright   :  (c) Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Heuristics for creating initial cabal files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.NonInteractive.Heuristics+  ( guessPackageName+  , guessMainFile+  , guessLicense+  , guessExtraDocFiles+  , guessAuthorName+  , guessAuthorEmail+  , guessCabalSpecVersion+  , guessLanguage+  , guessPackageType+  , guessSourceDirectories+  , guessApplicationDirectories+  ) where++import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many)+import Distribution.Utils.Generic (safeLast)++import Distribution.Simple.Setup (fromFlagOrDefault)++import qualified Data.List as L+import Distribution.Client.Init.Defaults+import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)+import Distribution.Client.Init.Types+import Distribution.Client.Init.Utils+import System.FilePath+import Distribution.CabalSpecVersion+import Language.Haskell.Extension+import Distribution.Version+import Distribution.Types.PackageName (PackageName, mkPackageName)+import Distribution.Simple.Compiler+import qualified Data.Set as Set+import Distribution.FieldGrammar.Newtypes++++-- | Guess the main file, returns a default value if none is found.+guessMainFile :: Interactive m => FilePath -> m HsFilePath+guessMainFile pkgDir = do+  exists <- doesDirectoryExist pkgDir+  if exists+    then do+      files  <- filter isMain <$> listFilesRecursive pkgDir+      return $ if null files+        then defaultMainIs+        else toHsFilePath $ L.head files+    else+      return defaultMainIs++-- | Juggling characters around to guess the desired cabal version based on+--   the system's cabal version.+guessCabalSpecVersion :: Interactive m => m CabalSpecVersion+guessCabalSpecVersion = do+  (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] ""+  case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of+    Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of+      [x,y,_,_] -> cabalSpecFromVersionDigits [x,y]+      [x,y,_] -> cabalSpecFromVersionDigits [x,y]+      _ -> Just defaultCabalVersion+    Nothing -> pure defaultCabalVersion++-- | Guess the language specification based on the GHC version+guessLanguage :: Interactive m => Compiler -> m Language+guessLanguage Compiler {compilerId = CompilerId GHC ver} =+    return $ if ver < mkVersion [7,0,1]+      then Haskell98+      else Haskell2010+guessLanguage _ = return defaultLanguage++-- | Guess the package name based on the given root directory.+guessPackageName :: Interactive m => FilePath -> m PackageName+guessPackageName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)+                 . canonicalizePathNoThrow+  where+    -- Treat each span of non-alphanumeric characters as a hyphen. Each+    -- hyphenated component of a package name must contain at least one+    -- alphabetic character. An arbitrary character ('x') will be prepended if+    -- this is not the case for the first component, and subsequent components+    -- will simply be run together. For example, "1+2_foo-3" will become+    -- "x12-foo3".+    repair = repair' ('x' :) id+    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of+        "" -> repairComponent ""+        x' -> let (c, r) = first repairComponent $ span isAlphaNum x'+              in c ++ repairRest r+      where+        repairComponent c | all isDigit c = invalid c+                          | otherwise     = valid c+    repairRest = repair' id ('-' :)++-- | Try to guess the license from an already existing @LICENSE@ file in+--   the package directory, comparing the file contents with the ones+--   listed in @Licenses.hs@, for now it only returns a default value.+guessLicense :: Interactive m => InitFlags -> m SpecLicense+guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags++guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath))+guessExtraDocFiles flags = do+  pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags+  files  <- getDirectoryContents pkgDir++  let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"]+      extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)]++  return $ Just $ if null extraDocs+    then Set.singleton defaultChangelog+    else Set.fromList extraDocs++-- | Try to guess the package type from the files in the package directory,+--   looking for unique characteristics from each type, defaults to Executable.+guessPackageType :: Interactive m => InitFlags -> m PackageType+guessPackageType flags = do+  if fromFlagOrDefault False (initializeTestSuite flags)+    then+      return TestSuite +    else do+      let lastDir dirs   = L.last . splitDirectories $ dirs+          srcCandidates  = [defaultSourceDir, "src", "source"]+          testCandidates = [defaultTestDir, "test", "tests"]++      pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags+      files  <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir+      files' <- filter (not . null . map (`elem` testCandidates) . splitDirectories) <$>+        listFilesRecursive pkgDir++      let hasExe   = not $ null [f | f <- files,  isMain $ takeFileName f]+          hasLib   = not $ null [f | f <- files,  lastDir f `elem` srcCandidates]+          hasTest  = not $ null [f | f <- files', isMain $ takeFileName f]++      return $ case (hasLib, hasExe, hasTest) of+        (True , True , _   ) -> LibraryAndExecutable+        (True , False, _   ) -> Library+        (False, False, True) -> TestSuite+        _                    -> Executable++-- | Try to guess the application directories from the package directory,+--   using a default value as fallback.+guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath]+guessApplicationDirectories flags = do+  pkgDirs <- fromFlagOrDefault getCurrentDirectory+                (return <$> packageDir flags)+  pkgDirsContents <- listDirectory pkgDirs++  let candidates = [defaultApplicationDir, "app", "src-exe"] in+    return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of+      [] -> [defaultApplicationDir]+      x  -> map (</> pkgDirs) . nub $ x++-- | Try to guess the source directories, using a default value as fallback.+guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath]+guessSourceDirectories flags = do+  pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags++  doesDirectoryExist (pkgDir </> "src") >>= return . \case+    False -> [defaultSourceDir]+    True  -> ["src"]++-- | Guess author and email using git configuration options.+guessAuthorName :: Interactive m => m String+guessAuthorName = guessGitInfo "user.name"++guessAuthorEmail :: Interactive m => m String+guessAuthorEmail = guessGitInfo "user.email"++guessGitInfo :: Interactive m => String -> m String+guessGitInfo target = do+  info <- readProcessWithExitCode "git" ["config", "--local", target] ""+  if null $ snd' info+    then trim . snd' <$> readProcessWithExitCode "git" ["config", "--global", target] ""+    else return . trim $ snd' info++  where+    snd' (_, x, _) = x
src/Distribution/Client/Init/Prompt.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Prompt@@ -12,134 +14,158 @@ -- ----------------------------------------------------------------------------- -module Distribution.Client.Init.Prompt (--    -- * Commands-    prompt-  , promptYesNo-  , promptStr-  , promptList-  , promptListOptional-  , maybePrompt-  ) where+module Distribution.Client.Init.Prompt+( prompt+, promptYesNo+, promptStr+, promptList+) where -import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)+import Prelude hiding (break, putStrLn, getLine, putStr) +import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn) import Distribution.Client.Init.Types-  ( InitFlags(..) )-import Distribution.Simple.Setup-  ( Flag(..) )+import qualified System.IO  --- | Run a prompt or not based on the interactive flag of the---   InitFlags structure.-maybePrompt :: InitFlags -> IO t -> IO (Maybe t)-maybePrompt flags p =-  case interactive flags of-    Flag True -> Just `fmap` p-    _         -> return Nothing- -- | Create a prompt with optional default value that returns a---   String.-promptStr :: String -> Maybe String -> IO String-promptStr = promptDefault' Just id+-- String.+promptStr :: Interactive m => String -> DefaultPrompt String -> m String+promptStr = promptDefault Right id  -- | Create a yes/no prompt with optional default value.-promptYesNo :: String      -- ^ prompt message-            -> Maybe Bool  -- ^ optional default value-            -> IO Bool+promptYesNo+    :: Interactive m+    => String+      -- ^ prompt message+    -> DefaultPrompt Bool+      -- ^ optional default value+    -> m Bool promptYesNo =-    promptDefault' recogniseYesNo showYesNo+    promptDefault recogniseYesNo showYesNo   where-    recogniseYesNo s | s == "y" || s == "Y" = Just True-                     | s == "n" || s == "N" = Just False-                     | otherwise            = Nothing+    recogniseYesNo s+      | (toLower <$> s) == "y" = Right True+      | (toLower <$> s) == "n" || s == "N" = Right False+      | otherwise = Left $ "Cannot parse input: " ++ s+     showYesNo True  = "y"     showYesNo False = "n"  -- | Create a prompt with optional default value that returns a value --   of some Text instance.-prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t-prompt = promptDefault' simpleParsec prettyShow---- | Create a prompt with an optional default value.-promptDefault' :: (String -> Maybe t)       -- ^ parser-               -> (t -> String)             -- ^ pretty-printer-               -> String                    -- ^ prompt message-               -> Maybe t                   -- ^ optional default value-               -> IO t-promptDefault' parser ppr pr def = do-  putStr $ mkDefPrompt pr (ppr `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d)  -> return d-    _  -> case parser inp of-            Just t  -> return t-            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"-                          promptDefault' parser ppr pr def+prompt :: (Interactive m, Parsec t, Pretty t) => String -> DefaultPrompt t -> m t+prompt = promptDefault eitherParsec prettyShow  -- | Create a prompt from a prompt string and a String representation --   of an optional default value.-mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ "?" ++ defStr def-  where defStr Nothing  = " "-        defStr (Just s) = " [default: " ++ s ++ "] "+mkDefPrompt :: String -> DefaultPrompt String -> String+mkDefPrompt msg def = msg ++ "?" ++ format def+  where+    format MandatoryPrompt = " "+    format OptionalPrompt = " [optional] "+    format (DefaultPrompt s) = " [default: " ++ s ++ "] " --- | Create a prompt from a list of items, where no selected items is---   valid and will be represented as a return value of 'Nothing'.-promptListOptional :: (Pretty t, Eq t)-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> IO (Maybe (Either String t))-promptListOptional pr choices = promptListOptional' pr choices prettyShow+-- | Create a prompt from a list of strings+promptList+    :: Interactive m+    => String+      -- ^ prompt+    -> [String]+      -- ^ choices+    -> DefaultPrompt String+      -- ^ optional default value+    -> Maybe (String -> String)+      -- ^ modify the default value to present in-prompt+      -- e.g. empty string maps to "(none)", but only in the+      -- prompt.+    -> Bool+      -- ^ whether to allow an 'other' option+    -> m String+promptList msg choices def modDef hasOther = do+  putStrLn $ msg ++ ":" -promptListOptional' :: Eq t-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> (t -> String)     -- ^ show an item-                   -> IO (Maybe (Either String t))-promptListOptional' pr choices displayItem =-    fmap rearrange-  $ promptList pr (Nothing : map Just choices) (Just Nothing)-               (maybe "(none)" displayItem) True-  where-    rearrange = either (Just . Left) (fmap Right)+  -- Output nicely formatted list of options+  for_ prettyChoices $ \(i,c) -> do+    let star = if DefaultPrompt c == def+          then "*"+          else " " --- | Create a prompt from a list of items.-promptList :: Eq t-           => String            -- ^ prompt-           -> [t]               -- ^ choices-           -> Maybe t           -- ^ optional default value-           -> (t -> String)     -- ^ show an item-           -> Bool              -- ^ whether to allow an 'other' option-           -> IO (Either String t)-promptList pr choices def displayItem other = do-  putStrLn $ pr ++ ":"-  let options1 = map (\c -> (Just c == def, displayItem c)) choices-      options2 = zip ([1..]::[Int])-                     (options1 ++ [(False, "Other (specify)") | other])-  traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2-  promptList' displayItem (length options2) choices def other- where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest-                      | otherwise = " " ++ star i ++ rest-                  where rest = show n ++ ") "-                        star True = "*"-                        star False = " "+    let output = concat $ if i < 10+          then [" ", star, " ", show i, ") ", c]+          else [" ", star, show i, ") ", c] -promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' displayItem numChoices choices def other = do-  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d) -> return $ Right d-    _  -> case readMaybe inp of-            Nothing -> invalidChoice inp-            Just n  -> getChoice n- where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."-                              promptList' displayItem numChoices choices def other-       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)-                   | n < numChoices ||-                     (n == numChoices && not other)-                                  = return . Right $ choices !! (n-1)-                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing+    putStrLn output++  go+ where+   prettyChoices =+     let cs = if hasOther+           then choices ++ ["Other (specify)"]+           else choices+     in zip [1::Int .. length choices + 1] cs++   numChoices = length choices++   invalidChoice input = do+      let msg' = if null input+            then "Empty input is not a valid choice."+            else concat+              [ input+              , " is not a valid choice. Please choose a number from 1 to "+              , show (length prettyChoices)+              , "."+              ]++      putStrLn msg'+      breakOrContinue ("promptList: " ++ input) go++   go = do+     putStr+       $ mkDefPrompt "Your choice"+       $ maybe def (<$> def) modDef++     input <- getLine+     case def of+       DefaultPrompt d | null input -> return d+       _ -> case readMaybe input of+         Nothing -> invalidChoice input+         Just n+           | n > 0, n <= numChoices -> return $ choices !! (n-1)+           | n == numChoices + 1, hasOther ->+             promptStr "Please specify" OptionalPrompt+           | otherwise -> invalidChoice (show n)++-- | Create a prompt with an optional default value.+promptDefault+    :: Interactive m+    => (String -> Either String t)+      -- ^ parser+    -> (t -> String)+      -- ^ pretty-printer+    -> String+      -- ^ prompt message+    -> (DefaultPrompt t)+      -- ^ optional default value+    -> m t+promptDefault parse pprint msg def = do+  putStr $ mkDefPrompt msg (pprint <$> def)+  hFlush System.IO.stdout+  input <- getLine+  case def of+    DefaultPrompt d | null input  -> return d+    _  -> case parse input of+      Right t  -> return t+      Left err -> do+        putStrLn $ "Couldn't parse " ++ input ++ ", please try again!"+        breakOrContinue+          ("promptDefault: " ++ err ++ " on input: " ++ input)+          (promptDefault parse pprint msg def)++-- | Prompt utility for breaking out of an interactive loop+-- in the pure case+--+breakOrContinue :: Interactive m => String -> m a -> m a+breakOrContinue msg act = break >>= \case+    True -> throwPrompt $ BreakException msg+    False -> act
+ src/Distribution/Client/Init/Simple.hs view
@@ -0,0 +1,175 @@+module Distribution.Client.Init.Simple+( -- * Project creation+  createProject+  -- * Gen targets+, genSimplePkgDesc+, genSimpleLibTarget+, genSimpleExeTarget+, genSimpleTestTarget+) where+++import Distribution.Client.Init.Types+import Distribution.Verbosity+import Distribution.Simple.PackageIndex+import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..))+import qualified Data.List.NonEmpty as NEL+import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles)+import Distribution.Client.Init.Defaults+import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag(..))+import Distribution.Client.Init.FlagExtractors+import qualified Data.Set as Set+import Distribution.Types.Dependency+import Distribution.Types.PackageName (unPackageName)+++createProject+    :: Interactive m+    => Verbosity+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> InitFlags+    -> m ProjectSettings+createProject v pkgIx _srcDb initFlags = do+    pkgType <- packageTypePrompt initFlags+    isMinimal <- getMinimal initFlags+    doOverwrite <- getOverwrite initFlags+    pkgDir <- getPackageDir initFlags+    pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags++    let pkgName = _pkgName pkgDesc+        cabalSpec = _pkgCabalVersion pkgDesc+        mkOpts cs = WriteOpts+          doOverwrite isMinimal cs+          v pkgDir pkgType pkgName++    basedFlags <- addBaseDepToFlags pkgIx initFlags++    case pkgType of+      Library -> do+        libTarget <- genSimpleLibTarget basedFlags+        testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags+        return $ ProjectSettings+          (mkOpts False cabalSpec) pkgDesc+          (Just libTarget) Nothing testTarget++      Executable -> do+        exeTarget <- genSimpleExeTarget basedFlags+        return $ ProjectSettings+          (mkOpts False cabalSpec) pkgDesc+          Nothing (Just exeTarget) Nothing++      LibraryAndExecutable -> do+        libTarget <- genSimpleLibTarget basedFlags+        testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags+        exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags+        return $ ProjectSettings+          (mkOpts False cabalSpec) pkgDesc+          (Just libTarget) (Just exeTarget) testTarget++      TestSuite -> do+        testTarget <- genSimpleTestTarget basedFlags+        return $ ProjectSettings+          (mkOpts False cabalSpec) pkgDesc+          Nothing Nothing testTarget+  where+    -- Add package name as dependency of test suite+    --+    addLibDepToTest _ Nothing = Nothing+    addLibDepToTest n (Just t) = Just $ t+      { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]+      }++    -- Add package name as dependency of executable+    --+    addLibDepToExe n exe = exe+      { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]+      }++genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription+genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName+  where+    defaultExtraDoc = Just $ Set.singleton defaultChangelog++    extractExtraDoc [] = defaultExtraDoc+    extractExtraDoc fs = Just $ Set.fromList fs++    mkPkgDesc pkgName = PkgDescription+      (fromFlagOrDefault defaultCabalVersion (cabalVersion flags))+      pkgName+      (fromFlagOrDefault defaultVersion (version flags))+      (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags))+      (fromFlagOrDefault "" (author flags))+      (fromFlagOrDefault "" (email flags))+      (fromFlagOrDefault "" (homepage flags))+      (fromFlagOrDefault "" (synopsis flags))+      (fromFlagOrDefault "" (category flags))+      (flagElim mempty Set.fromList (extraSrc flags))+      (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags))++genSimpleLibTarget :: Interactive m => InitFlags -> m LibTarget+genSimpleLibTarget flags = do+    buildToolDeps <- getBuildTools flags+    return $ LibTarget+      { _libSourceDirs = fromFlagOrDefault [defaultSourceDir] $ sourceDirs flags+      , _libLanguage = fromFlagOrDefault defaultLanguage $ language flags+      , _libExposedModules =+        flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags+      , _libOtherModules = fromFlagOrDefault [] $ otherModules flags+      , _libOtherExts = fromFlagOrDefault [] $ otherExts flags+      , _libDependencies = fromFlagOrDefault [] $ dependencies flags+      , _libBuildTools = buildToolDeps+      }++  where+    extractMods [] = myLibModule NEL.:| []+    extractMods as = NEL.fromList as++genSimpleExeTarget :: Interactive m => InitFlags -> m ExeTarget+genSimpleExeTarget flags = do+    buildToolDeps <- getBuildTools flags+    return $ ExeTarget+      { _exeMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags+      , _exeApplicationDirs  =+        fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags+      , _exeLanguage = fromFlagOrDefault defaultLanguage $ language flags+      , _exeOtherModules = fromFlagOrDefault [] $ otherModules flags+      , _exeOtherExts = fromFlagOrDefault [] $ otherExts flags+      , _exeDependencies = fromFlagOrDefault [] $ dependencies flags+      , _exeBuildTools = buildToolDeps+      }++genSimpleTestTarget :: Interactive m => InitFlags -> m (Maybe TestTarget)+genSimpleTestTarget flags = go =<< initializeTestSuitePrompt flags+  where+    go initialized+      | not initialized = return Nothing+      | otherwise = do+        buildToolDeps <- getBuildTools flags+        return $ Just $ TestTarget+          { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags+          , _testDirs  = fromFlagOrDefault [defaultTestDir] $ testDirs flags+          , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags+          , _testOtherModules = fromFlagOrDefault [] $ otherModules flags+          , _testOtherExts = fromFlagOrDefault [] $ otherExts flags+          , _testDependencies = fromFlagOrDefault [] $ dependencies flags+          , _testBuildTools = buildToolDeps+          }++-- -------------------------------------------------------------------- --+-- Utils++-- | If deps are defined, and base is present, we skip the search for base.+-- otherwise, we look up @base@ and add it to the list.+addBaseDepToFlags :: Interactive m => InstalledPackageIndex -> InitFlags -> m InitFlags+addBaseDepToFlags pkgIx initFlags = case dependencies initFlags of+  Flag as+    | any ((==) "base" . unPackageName . depPkgName) as -> return initFlags+    | otherwise -> do+      based <- dependenciesPrompt pkgIx initFlags+      return $ initFlags+        { dependencies = Flag $ based ++ as+        }+  _ -> do+    based <- dependenciesPrompt pkgIx initFlags+    return initFlags { dependencies = Flag based }
src/Distribution/Client/Init/Types.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-------------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-} -- | -- Module      :  Distribution.Client.Init.Types -- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009@@ -12,131 +13,460 @@ -- -- Some types used by the 'cabal init' command. ---------------------------------------------------------------------------------module Distribution.Client.Init.Types where+module Distribution.Client.Init.Types+( -- * Data+  InitFlags(..)+  -- ** Targets and descriptions+, PkgDescription(..)+, LibTarget(..)+, ExeTarget(..)+, TestTarget(..)+  -- ** package types+, PackageType(..)+  -- ** Main file+, HsFilePath(..)+, HsFileType(..)+, fromHsFilePath+, toHsFilePath+, toLiterateHs+, toStandardHs+, mkLiterate+, isHsFilePath+  -- * Typeclasses+, Interactive(..)+, BreakException(..)+, PurePrompt(..)+, evalPrompt+, Severity(..)+  -- * Aliases+, IsLiterate+, IsSimple+  -- * File creator opts+, WriteOpts(..)+, ProjectSettings(..)+  -- * Formatters+, FieldAnnotation(..)+  -- * Other conveniences+, DefaultPrompt(..)+) where -import Distribution.Client.Compat.Prelude-import Prelude () -import Distribution.Simple.Setup (Flag(..), toFlag )+import qualified Distribution.Client.Compat.Prelude as P+import Distribution.Client.Compat.Prelude as P hiding (getLine, putStr, putStrLn)+import Prelude (read) +import Control.Monad.Catch++import Data.List.NonEmpty (fromList)++import Distribution.Simple.Setup (Flag(..)) import Distribution.Types.Dependency as P+import Distribution.Verbosity (silent) import Distribution.Version-import Distribution.Verbosity import qualified Distribution.Package as P-import Distribution.SPDX.License (License) import Distribution.ModuleName import Distribution.CabalSpecVersion+import Distribution.Client.Utils as P+import Distribution.Fields.Pretty import Language.Haskell.Extension ( Language(..), Extension )+import qualified System.IO -import qualified Text.PrettyPrint as Disp-import qualified Distribution.Compat.CharParsing as P-import qualified Data.Map as Map+import qualified System.Directory as P+import qualified System.Process as P+import qualified Distribution.Compat.Environment as P+import System.FilePath+import Distribution.FieldGrammar.Newtypes (SpecLicense) --- | InitFlags is really just a simple type to represent certain---   portions of a .cabal file.  Rather than have a flag for EVERY---   possible field, we just have one for each field that the user is---   likely to want and/or that we are likely to be able to---   intelligently guess.++-- -------------------------------------------------------------------- --+-- Flags++-- | InitFlags is a subset of flags available in the+-- @.cabal@ file that represent options that are relevant to the+-- init command process.+-- data InitFlags =-    InitFlags { interactive    :: Flag Bool-              , quiet          :: Flag Bool-              , packageDir     :: Flag FilePath-              , noComments     :: Flag Bool-              , minimal        :: Flag Bool-              , simpleProject  :: Flag Bool+    InitFlags+    { interactive :: Flag Bool+    , quiet :: Flag Bool+    , packageDir :: Flag FilePath+    , noComments :: Flag Bool+    , minimal :: Flag Bool+    , simpleProject :: Flag Bool+    , packageName :: Flag P.PackageName+    , version :: Flag Version+    , cabalVersion :: Flag CabalSpecVersion+    , license :: Flag SpecLicense+    , author :: Flag String+    , email :: Flag String+    , homepage :: Flag String+    , synopsis :: Flag String+    , category :: Flag String+    , extraSrc :: Flag [String]+    , extraDoc :: Flag [String]+    , packageType :: Flag PackageType+    , mainIs :: Flag FilePath+    , language :: Flag Language+    , exposedModules :: Flag [ModuleName]+    , otherModules :: Flag [ModuleName]+    , otherExts :: Flag [Extension]+    , dependencies :: Flag [P.Dependency]+    , applicationDirs :: Flag [String]+    , sourceDirs :: Flag [String]+    , buildTools :: Flag [String]+    , initializeTestSuite :: Flag Bool+    , testDirs :: Flag [String]+    , initHcPath :: Flag FilePath+    , initVerbosity :: Flag Verbosity+    , overwrite :: Flag Bool+    } deriving (Eq, Show, Generic) -              , packageName  :: Flag P.PackageName-              , version      :: Flag Version-              , cabalVersion :: Flag CabalSpecVersion-              , license      :: Flag License-              , author       :: Flag String-              , email        :: Flag String-              , homepage     :: Flag String+instance Monoid InitFlags where+  mempty = gmempty+  mappend = (<>) -              , synopsis     :: Flag String-              , category     :: Flag (Either String Category)-              , extraSrc     :: Maybe [String]+instance Semigroup InitFlags where+  (<>) = gmappend -              , packageType  :: Flag PackageType-              , mainIs       :: Flag FilePath-              , language     :: Flag Language+-- -------------------------------------------------------------------- --+-- Targets -              , exposedModules :: Maybe [ModuleName]-              , otherModules   :: Maybe [ModuleName]-              , otherExts      :: Maybe [Extension]+-- | 'PkgDescription' represents the relevant options set by the+-- user when building a package description during the init command+-- process.+--+data PkgDescription = PkgDescription+    { _pkgCabalVersion :: CabalSpecVersion+    , _pkgName :: P.PackageName+    , _pkgVersion :: Version+    , _pkgLicense :: SpecLicense+    , _pkgAuthor :: String+    , _pkgEmail :: String+    , _pkgHomePage :: String+    , _pkgSynopsis :: String+    , _pkgCategory :: String+    , _pkgExtraSrcFiles :: Set String+    , _pkgExtraDocFiles :: Maybe (Set String)+    } deriving (Show, Eq) -              , dependencies    :: Maybe [P.Dependency]-              , applicationDirs :: Maybe [String]-              , sourceDirs      :: Maybe [String]-              , buildTools      :: Maybe [String]+-- | 'LibTarget' represents the relevant options set by the+-- user when building a library package during the init command+-- process.+--+data LibTarget = LibTarget+    { _libSourceDirs :: [String]+    , _libLanguage :: Language+    , _libExposedModules :: NonEmpty ModuleName+    , _libOtherModules :: [ModuleName]+    , _libOtherExts :: [Extension]+    , _libDependencies :: [P.Dependency]+    , _libBuildTools :: [P.Dependency]+    } deriving (Show, Eq) -              , initializeTestSuite :: Flag Bool-              , testDirs            :: Maybe [String]+-- | 'ExeTarget' represents the relevant options set by the+-- user when building an executable package.+--+data ExeTarget = ExeTarget+    { _exeMainIs :: HsFilePath+    , _exeApplicationDirs :: [String]+    , _exeLanguage :: Language+    , _exeOtherModules :: [ModuleName]+    , _exeOtherExts :: [Extension]+    , _exeDependencies :: [P.Dependency]+    , _exeBuildTools :: [P.Dependency]+    } deriving (Show, Eq) -              , initHcPath    :: Flag FilePath+-- | 'TestTarget' represents the relevant options set by the+-- user when building a library package.+--+data TestTarget = TestTarget+    { _testMainIs :: HsFilePath+    , _testDirs :: [String]+    , _testLanguage :: Language+    , _testOtherModules :: [ModuleName]+    , _testOtherExts :: [Extension]+    , _testDependencies :: [P.Dependency]+    , _testBuildTools :: [P.Dependency]+    } deriving (Show, Eq) -              , initVerbosity :: Flag Verbosity-              , overwrite     :: Flag Bool-              }-  deriving (Eq, Show, Generic)+-- -------------------------------------------------------------------- --+-- File creator options -  -- the Monoid instance for Flag has later values override earlier-  -- ones, which is why we want Maybe [foo] for collecting foo values,-  -- not Flag [foo].+data WriteOpts = WriteOpts+    { _optOverwrite :: Bool+    , _optMinimal :: Bool+    , _optNoComments :: Bool+    , _optVerbosity :: Verbosity+    , _optPkgDir :: FilePath+    , _optPkgType :: PackageType+    , _optPkgName :: P.PackageName+    , _optCabalSpec :: CabalSpecVersion+    } deriving (Eq, Show) -data BuildType = LibBuild | ExecBuild-  deriving Eq+data ProjectSettings = ProjectSettings+    { _pkgOpts :: WriteOpts+    , _pkgDesc :: PkgDescription+    , _pkgLibTarget :: Maybe LibTarget+    , _pkgExeTarget :: Maybe ExeTarget+    , _pkgTestTarget :: Maybe TestTarget+    } deriving (Eq, Show) --- The type of package to initialize.-data PackageType = Library | Executable | LibraryAndExecutable-  deriving (Show, Read, Eq)+-- -------------------------------------------------------------------- --+-- Other types -displayPackageType :: PackageType -> String-displayPackageType LibraryAndExecutable = "Library and Executable"-displayPackageType pkgtype              = show pkgtype+-- | Enum to denote whether the user wants to build a library target,+-- executable target, library and executable targets, or a standalone test suite.+--+data PackageType = Library | Executable | LibraryAndExecutable | TestSuite+    deriving (Eq, Show, Generic) -instance Monoid InitFlags where-  mempty = gmempty-  mappend = (<>)+data HsFileType+    = Literate+    | Standard+    | InvalidHsPath+    deriving (Eq, Show) -instance Semigroup InitFlags where-  (<>) = gmappend+data HsFilePath = HsFilePath+    { _hsFilePath :: FilePath+    , _hsFileType :: HsFileType+    } deriving Eq -defaultInitFlags :: InitFlags-defaultInitFlags  = mempty-    { initVerbosity = toFlag normal-    }+instance Show HsFilePath where+    show (HsFilePath fp ty) = case ty of+      Literate -> fp+      Standard -> fp+      InvalidHsPath -> "Invalid haskell source file: " ++ fp --- | Some common package categories (non-exhaustive list).-data Category-    = Codec-    | Concurrency-    | Control-    | Data-    | Database-    | Development-    | Distribution-    | Game-    | Graphics-    | Language-    | Math-    | Network-    | Sound-    | System-    | Testing-    | Text-    | Web-    deriving (Read, Show, Eq, Ord, Bounded, Enum)+fromHsFilePath :: HsFilePath -> Maybe FilePath+fromHsFilePath (HsFilePath fp ty) = case ty of+    Literate -> Just fp+    Standard -> Just fp+    InvalidHsPath -> Nothing -instance Pretty Category where-  pretty = Disp.text . show+isHsFilePath :: FilePath -> Bool+isHsFilePath fp = case _hsFileType $ toHsFilePath fp of+    InvalidHsPath -> False+    _ -> True -instance Parsec Category where-  parsec = do-    name <- P.munch1 isAlpha-    case Map.lookup name names of-      Just cat -> pure cat-      _        -> P.unexpected $ "Category: " ++ name-    where-      names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ]+toHsFilePath :: FilePath -> HsFilePath+toHsFilePath fp+    | takeExtension fp == ".lhs" = HsFilePath fp Literate+    | takeExtension fp == ".hs" = HsFilePath fp Standard+    | otherwise = HsFilePath fp InvalidHsPath++toLiterateHs :: HsFilePath -> HsFilePath+toLiterateHs (HsFilePath fp Standard) = HsFilePath+    (dropExtension fp ++ ".lhs")+    Literate+toLiterateHs a = a++toStandardHs :: HsFilePath -> HsFilePath+toStandardHs (HsFilePath fp Literate) = HsFilePath+    (dropExtension fp ++ ".hs")+    Standard+toStandardHs a = a++mkLiterate :: HsFilePath -> [String] -> [String]+mkLiterate (HsFilePath _ Literate) hs =+    (\line -> if null line then line else "> " ++ line) <$> hs+mkLiterate _ hs = hs++-- -------------------------------------------------------------------- --+-- Interactive prompt monad++newtype PurePrompt a = PurePrompt+    { _runPrompt+        :: NonEmpty String+        -> Either BreakException (a, NonEmpty String)+    } deriving (Functor)++evalPrompt :: PurePrompt a -> NonEmpty String -> a+evalPrompt act s = case _runPrompt act s of+    Left e -> error $ show e+    Right (a,_) -> a++instance Applicative PurePrompt where+    pure a = PurePrompt $ \s -> Right (a, s)+    PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of+      Left e -> Left e+      Right (f, s') -> case aa s' of+        Left e -> Left e+        Right (a, s'') -> Right (f a, s'')++instance Monad PurePrompt where+    return = pure+    PurePrompt a >>= k = PurePrompt $ \s -> case a s of+      Left e -> Left e+      Right (a', s') -> _runPrompt (k a') s'++class Monad m => Interactive m where+    -- input functions+    getLine :: m String+    readFile :: FilePath -> m String+    getCurrentDirectory :: m FilePath+    getHomeDirectory :: m FilePath+    getDirectoryContents :: FilePath -> m [FilePath]+    listDirectory :: FilePath -> m [FilePath]+    doesDirectoryExist :: FilePath -> m Bool+    doesFileExist :: FilePath -> m Bool+    canonicalizePathNoThrow :: FilePath -> m FilePath+    readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)+    getEnvironment :: m [(String, String)]+    getCurrentYear :: m Integer+    listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]+    listFilesRecursive :: FilePath -> m [FilePath]++    -- output functions+    putStr :: String -> m ()+    putStrLn :: String -> m ()+    createDirectory :: FilePath -> m ()+    removeDirectory :: FilePath -> m ()+    writeFile :: FilePath -> String -> m ()+    removeExistingFile :: FilePath -> m ()+    copyFile :: FilePath -> FilePath -> m ()+    renameDirectory :: FilePath -> FilePath -> m ()+    hFlush :: System.IO.Handle -> m ()+    message :: Verbosity -> Severity -> String -> m ()++    -- misc functions+    break :: m Bool+    throwPrompt :: BreakException -> m a++instance Interactive IO where+    getLine = P.getLine+    readFile = P.readFile+    getCurrentDirectory = P.getCurrentDirectory+    getHomeDirectory = P.getHomeDirectory+    getDirectoryContents = P.getDirectoryContents+    listDirectory = P.listDirectory+    doesDirectoryExist = P.doesDirectoryExist+    doesFileExist = P.doesFileExist+    canonicalizePathNoThrow = P.canonicalizePathNoThrow+    readProcessWithExitCode = P.readProcessWithExitCode+    getEnvironment = P.getEnvironment+    getCurrentYear = P.getCurrentYear+    listFilesInside = P.listFilesInside+    listFilesRecursive = P.listFilesRecursive++    putStr = P.putStr+    putStrLn = P.putStrLn+    createDirectory = P.createDirectory+    removeDirectory = P.removeDirectoryRecursive+    writeFile = P.writeFile+    removeExistingFile = P.removeExistingFile+    copyFile = P.copyFile+    renameDirectory = P.renameDirectory+    hFlush = System.IO.hFlush+    message q severity msg+      | q == silent = pure ()+      | otherwise  = putStrLn $ "[" ++ show severity ++ "] " ++ msg+    break = return False+    throwPrompt = throwM++instance Interactive PurePrompt where+    getLine = pop+    readFile !_ = pop+    getCurrentDirectory = popAbsolute+    getHomeDirectory = popAbsolute+    -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]"+    getDirectoryContents !_ = popList+    listDirectory !_ = popList+    doesDirectoryExist !_ = popBool+    doesFileExist !_ = popBool+    canonicalizePathNoThrow !_ = popAbsolute+    readProcessWithExitCode !_ !_ !_ = do+      input <- pop+      return (ExitSuccess, input, "")+    getEnvironment = fmap (map read) popList+    getCurrentYear = fmap read pop+    listFilesInside pred' !_ = do+      input <- map splitDirectories <$> popList+      map joinPath <$> filterM (fmap and . traverse pred') input+    listFilesRecursive !_ = popList++    putStr !_ = return ()+    putStrLn !_ = return ()+    createDirectory !d = checkInvalidPath d ()+    removeDirectory !d = checkInvalidPath d ()+    writeFile !f !_ = checkInvalidPath f ()+    removeExistingFile !f = checkInvalidPath f ()+    copyFile !f !_ = checkInvalidPath f ()+    renameDirectory !d !_ = checkInvalidPath d ()+    hFlush _ = return ()+    message !_ !severity !msg = case severity of+      Error -> PurePrompt $ \_ -> Left $ BreakException+        (show severity ++ ": " ++ msg)+      _     -> return ()++    break = return True+    throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException+      ("Error: " ++ e ++ "\nStacktrace: " ++ show s)++pop :: PurePrompt String+pop = PurePrompt $ \ (p:|ps) -> Right (p,fromList ps)++popAbsolute :: PurePrompt String+popAbsolute = do+    input <- pop+    return $ "/home/test/" ++ input++popBool :: PurePrompt Bool+popBool = pop >>= \case+    "True" -> pure True+    "False" -> pure False+    s -> throwPrompt $ BreakException $ "popBool: " ++ s++popList :: PurePrompt [String]+popList = pop >>= \a -> case P.safeRead a of+    Nothing -> throwPrompt $ BreakException ("popList: " ++ show a)+    Just as -> return as++checkInvalidPath :: String -> a -> PurePrompt a+checkInvalidPath path act =+    -- The check below is done this way so it's easier to append+    -- more invalid paths in the future, if necessary+    if path `elem` ["."] then+      throwPrompt $ BreakException $ "Invalid path: " ++ path+    else+      return act++-- | A pure exception thrown exclusively by the pure prompter+-- to cancel infinite loops in the prompting process.+--+-- For example, in order to break on parse errors, or user-driven+-- continuations that do not make sense to test.+--+newtype BreakException = BreakException String deriving (Eq, Show)++instance Exception BreakException++-- | Used to inform the intent of prompted messages.+--+data Severity = Log | Info | Warning | Error deriving (Eq, Show)++-- | Convenience alias for the literate haskell flag+--+type IsLiterate = Bool++-- | Convenience alias for generating simple projects+--+type IsSimple = Bool++-- | Defines whether or not a prompt will have a default value,+--   is optional, or is mandatory.+data DefaultPrompt t+  = DefaultPrompt t+  | OptionalPrompt+  | MandatoryPrompt+  deriving (Eq, Functor)++-- -------------------------------------------------------------------- --+-- Field annotation for pretty formatters++-- | Annotations for cabal file PrettyField.+data FieldAnnotation = FieldAnnotation+  { annCommentedOut :: Bool+    -- ^ True iif the field and its contents should be commented out.+  , annCommentLines :: CommentPosition+    -- ^ Comment lines to place before the field or section.+  }
src/Distribution/Client/Init/Utils.hs view
@@ -1,38 +1,329 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Utils--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Shared utilities used by multiple cabal init modules.---------------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.Init.Utils (-    eligibleForTestSuite-  , message-  ) where+module Distribution.Client.Init.Utils+( SourceFileEntry(..)+, retrieveSourceFiles+, retrieveModuleName+, retrieveModuleImports+, retrieveModuleExtensions+, retrieveBuildTools+, retrieveDependencies+, isMain+, isHaskell+, isSourceFile+, trim+, currentDirPkgName+, filePathToPkgName+, mkPackageNameDep+, fixupDocFiles+, mkStringyDep+, getBaseDep+, addLibDepToExe+, addLibDepToTest+) where -import Distribution.Solver.Compat.Prelude-import Prelude () -import Distribution.Simple.Setup-  ( Flag(..) )+import qualified Prelude+import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many)+import Distribution.Utils.Generic (isInfixOf)++import Control.Monad (forM)++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Language.Haskell.Extension (Extension(..))+import System.FilePath++import Distribution.CabalSpecVersion (CabalSpecVersion(..))+import Distribution.ModuleName (ModuleName)+import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed)+import qualified Distribution.Package as P+import qualified Distribution.Types.PackageName as PN+import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex)+import Distribution.Simple.Setup (Flag(..))+import Distribution.Utils.String (trim)+import Distribution.Version+import Distribution.Client.Init.Defaults import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..) )+import Distribution.Client.Utils (pvpize)+import Distribution.Types.PackageName+import Distribution.Types.Dependency (Dependency, mkDependency)+import qualified Distribution.Compat.NonEmptySet as NES+import Distribution.Types.LibraryName+import Distribution.Verbosity (silent) --- | Returns true if this package is eligible for test suite initialization.-eligibleForTestSuite :: InitFlags -> Bool-eligibleForTestSuite flags =-  Flag True == initializeTestSuite flags-  && Flag Executable /= packageType flags --- | Possibly generate a message to stdout, taking into account the---   --quiet flag.-message :: InitFlags -> String -> IO ()-message (InitFlags{quiet = Flag True}) _ = return ()-message _ s = putStrLn s+-- |Data type of source files found in the working directory+data SourceFileEntry = SourceFileEntry+    { relativeSourcePath :: FilePath+    , moduleName         :: ModuleName+    , fileExtension      :: String+    , imports            :: [ModuleName]+    , extensions         :: [Extension]+    } deriving Show++-- Unfortunately we cannot use the version exported by Distribution.Simple.Program+knownSuffixHandlers :: CabalSpecVersion -> String -> String+knownSuffixHandlers v s+  | v < CabalSpecV3_0 = case s of+      ".gc" -> "greencard"+      ".chs" -> "chs"+      ".hsc" -> "hsc2hs"+      ".x" -> "alex"+      ".y" -> "happy"+      ".ly" -> "happy"+      ".cpphs" -> "cpp"+      _ -> ""+  | otherwise = case s of+      ".gc" -> "greencard:greencard"+      ".chs" -> "chs:chs"+      ".hsc" -> "hsc2hs:hsc2hs"+      ".x" -> "alex:alex"+      ".y" -> "happy:happy"+      ".ly" -> "happy:happy"+      ".cpphs" -> "cpp:cpp"+      _ -> ""+++-- | Check if a given file has main file characteristics+isMain :: String -> Bool+isMain f = (isInfixOf "Main" f || isInfixOf "main" f)+         && isSuffixOf ".hs" f || isSuffixOf ".lhs" f++-- | Check if a given file has a Haskell extension+isHaskell :: String -> Bool+isHaskell f = isSuffixOf ".hs" f || isSuffixOf ".lhs" f++isBuildTool :: CabalSpecVersion -> String -> Bool+isBuildTool v = not . null . knownSuffixHandlers v . takeExtension++retrieveBuildTools :: Interactive m => CabalSpecVersion -> FilePath -> m [Dependency]+retrieveBuildTools v fp = do+  exists <- doesDirectoryExist fp+  if exists+    then do+      files <- fmap takeExtension <$> listFilesRecursive fp++      let tools =+            [ mkStringyDep (knownSuffixHandlers v f)+            | f <- files, isBuildTool v f+            ]++      return tools++    else+      return []++retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry]+retrieveSourceFiles fp = do+  exists <- doesDirectoryExist fp+  if exists+    then do+      files <- filter isHaskell <$> listFilesRecursive fp++      entries <- forM files $ \f -> do+        exists' <- doesFileExist f+        if exists'+          then do+            maybeModuleName <- retrieveModuleName f+            case maybeModuleName of+              Nothing -> return Nothing+              Just moduleName -> do++                let fileExtension   = takeExtension f+                relativeSourcePath <- makeRelative f <$> getCurrentDirectory+                imports            <- retrieveModuleImports f+                extensions         <- retrieveModuleExtensions f++                return . Just $ SourceFileEntry {..}+          else+            return Nothing++      return . catMaybes $ entries++  else+    return []++-- | Given a module, retrieve its name+retrieveModuleName :: Interactive m => FilePath -> m (Maybe ModuleName)+retrieveModuleName m = do+    rawModule <- trim . grabModuleName <$> readFile m++    if isInfixOf rawModule (dirToModuleName m)+      then+        return $ Just $ fromString rawModule+      else do+        putStrLn+          $ "Warning: found module that doesn't match directory structure: "+          ++ rawModule+        return Nothing+  where+    dirToModuleName = map (\x -> if x == '/' || x == '\\' then '.' else x)++    stop c = (c /= '\n') && (c /= ' ')++    grabModuleName [] = []+    grabModuleName ('-':'-':xs) = grabModuleName $ dropWhile' (/= '\n') xs+    grabModuleName ('m':'o':'d':'u':'l':'e':' ':xs) = takeWhile' stop xs+    grabModuleName (_:xs) = grabModuleName xs++-- | Given a module, retrieve all of its imports+retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName]+retrieveModuleImports m = do+  map (fromString . trim) . grabModuleImports <$> readFile m++  where+    stop c = (c /= '\n') && (c /= ' ') && (c /= '(')++    grabModuleImports [] = []+    grabModuleImports ('-':'-':xs) = grabModuleImports $ dropWhile' (/= '\n') xs+    grabModuleImports ('i':'m':'p':'o':'r':'t':' ':xs) = case trim xs of -- in case someone uses a weird formatting+      ('q':'u':'a':'l':'i':'f':'i':'e':'d':' ':ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys)+      _                                            -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs)+    grabModuleImports (_:xs) = grabModuleImports xs++-- | Given a module, retrieve all of its language pragmas+retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension]+retrieveModuleExtensions m = do+  catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m++  where+    stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#')++    grabModuleExtensions [] = []+    grabModuleExtensions ('-':'-':xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs+    grabModuleExtensions ('L':'A':'N':'G':'U':'A':'G':'E':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)+    grabModuleExtensions (_:xs) = grabModuleExtensions xs++    grabModuleExtensions' [] = []+    grabModuleExtensions' ('#':xs) = grabModuleExtensions xs+    grabModuleExtensions' (',':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)+    grabModuleExtensions' (_:xs) = grabModuleExtensions xs++takeWhile' :: (Char -> Bool) -> String -> String+takeWhile' p = takeWhile p . trim++dropWhile' :: (Char -> Bool) -> String -> String+dropWhile' p = dropWhile p . trim++-- | Check whether a potential source file is located in one of the+--   source directories.+isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool+isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf+isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs++retrieveDependencies :: Interactive m => Verbosity -> InitFlags -> [(ModuleName, ModuleName)] -> InstalledPackageIndex -> m [P.Dependency]+retrieveDependencies v flags mods' pkgIx = do+  let mods = mods'++      modMap :: M.Map ModuleName [InstalledPackageInfo]+      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx++      modDeps :: [(ModuleName, ModuleName, Maybe [InstalledPackageInfo])]+      modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods+      -- modDeps = map (id &&& flip M.lookup modMap) mods++  message v Log "Guessing dependencies..."+  nub . catMaybes <$> traverse (chooseDep v flags) modDeps++-- Given a module and a list of installed packages providing it,+-- choose a dependency (i.e. package + version range) to use for that+-- module.+chooseDep+  :: Interactive m+  => Verbosity+  -> InitFlags+  -> (ModuleName, ModuleName, Maybe [InstalledPackageInfo])+  -> m (Maybe P.Dependency)+chooseDep v flags (importer, m, mipi) = case mipi of+  -- We found some packages: group them by name.+  Just ps@(_:_) ->+    case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of+    -- if there's only one group, i.e. multiple versions of a single package,+    -- we make it into a dependency, choosing the latest-ish version.++      -- Given a list of available versions of the same package, pick a dependency.+      [grp] -> fmap Just $ case grp of++        -- If only one version, easy. We change e.g. 0.4.2  into  0.4.*+        (pid:|[]) ->+          return $ P.Dependency+              (P.pkgName pid)+              (pvpize desugar . P.pkgVersion $ pid)+              P.mainLibSet --TODO sublibraries++        -- Otherwise, choose the latest version and issue a warning.+        pids -> do+          message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")+          return $ P.Dependency+              (P.pkgName . NE.head $ pids)+              (pvpize desugar . maximum . fmap P.pkgVersion $ pids)+              P.mainLibSet --TODO take into account sublibraries++      -- if multiple packages are found, we refuse to choose between+      -- different packages and make the user do it+      grps     -> do+        message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))+        message v Warning "You will need to pick one and manually add it to the build-depends field."+        return Nothing++  _ -> do+    message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".")+    return Nothing++  where+    -- desugar if cabal version lower than 2.0+    desugar = case cabalVersion flags of+      Flag x -> x                   < CabalSpecV2_0+      NoFlag -> defaultCabalVersion < CabalSpecV2_0++filePathToPkgName :: FilePath -> P.PackageName+filePathToPkgName = PN.mkPackageName . Prelude.last . splitDirectories++currentDirPkgName :: Interactive m => m P.PackageName+currentDirPkgName = filePathToPkgName <$> getCurrentDirectory++mkPackageNameDep :: PackageName -> Dependency+mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName)++-- when cabal-version < 1.18, extra-doc-files is not supported+-- so whatever the user wants as doc files should be dumped into+-- extra-src-files.+--+fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription+fixupDocFiles v pkgDesc+  | _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do+    message v Warning $ concat+      [ "Cabal spec versions < 1.18 do not support extra-doc-files. "+      , "Doc files will be treated as extra-src-files."+      ]++    return $ pkgDesc+      { _pkgExtraSrcFiles =_pkgExtraSrcFiles pkgDesc+        <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc)+      , _pkgExtraDocFiles = Nothing+      }+  | otherwise = return pkgDesc++mkStringyDep :: String -> Dependency+mkStringyDep = mkPackageNameDep . mkPackageName+++getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency]+getBaseDep pkgIx flags = retrieveDependencies silent flags+  [(fromString "Prelude", fromString "Prelude")] pkgIx++-- Add package name as dependency of test suite+--+addLibDepToTest :: PackageName -> Maybe TestTarget -> Maybe TestTarget+addLibDepToTest _ Nothing = Nothing+addLibDepToTest n (Just t) = Just $ t+  { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]+  }++-- Add package name as dependency of executable+--+addLibDepToExe :: PackageName -> ExeTarget -> ExeTarget+addLibDepToExe n exe = exe+  { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]+  }
src/Distribution/Client/Install.hs view
@@ -86,7 +86,6 @@          ( symlinkBinaries ) import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade-import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Client.JobControl @@ -129,8 +128,6 @@          ( PackageIdentifier(..), PackageId, packageName, packageVersion          , Package(..), HasMungedPackageId(..), HasUnitId(..)          , UnitId )-import Distribution.Types.Dependency-         ( Dependency (..), mainLibSet ) import Distribution.Types.GivenComponent          ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint@@ -165,11 +162,9 @@ --   * complain about flags that do not apply to any package given as target --     so flags do not apply to dependencies, only listed, can use flag --     constraints for dependencies---   * only record applicable flags in world file -- * allow flag constraints -- * allow installed constraints -- * allow flag and installed preferences--- * change world file to use cabal section syntax --   * allow persistent configure flags for each package individually  -- ------------------------------------------------------------@@ -257,7 +252,7 @@                       -> IO InstallContext makeInstallContext verbosity   (packageDBs, repoCtxt, comp, _, progdb,-   globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do+   _, _, configExFlags, installFlags, _, _, _) mUserTargets = do      let idxState = flagToMaybe (installIndexState installFlags) @@ -282,7 +277,6 @@                         | otherwise         = userTargets0          pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                         (fromFlag $ globalWorldFile globalFlags)                          (packageIndex sourcePkgDb)                          userTargets         return (userTargets, pkgSpecifiers)@@ -798,7 +792,6 @@ --  * build reporting, local and remote --  * symlinking binaries --  * updating indexes---  * updating world file --  * error reporting -- postInstallActions :: Verbosity@@ -810,13 +803,7 @@ postInstallActions verbosity   (packageDBs, _, comp, platform, progdb   ,globalFlags, configFlags, _, installFlags, _, _, _)-  targets installPlan buildOutcomes = do--  unless oneShot $-    World.insert verbosity worldFile-      --FIXME: does not handle flags-      [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty-      | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ]+  _ installPlan buildOutcomes = do    let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)                                                   installPlan buildOutcomes@@ -840,8 +827,6 @@   where     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags)-    oneShot        = fromFlag (installOneShot installFlags)-    worldFile      = fromFlag $ globalWorldFile globalFlags  storeDetailedBuildReports :: Verbosity -> FilePath                           -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()@@ -978,7 +963,7 @@        | (pkgid, Left failure) <- Map.toList buildOutcomes ] of     []     -> return ()     failed -> die' verbosity . unlines-            $ "Error: some packages failed to install:"+            $ "Some packages failed to install:"             : [ prettyShow pkgid ++ printFailureReason reason               | (pkgid, reason) <- failed ]   where
src/Distribution/Client/InstallPlan.hs view
@@ -708,7 +708,7 @@     -- The failed set is upwards closed, i.e. equal to its own rev dep closure     assert (failedSet == reverseClosure failedSet) $ -    -- All immediate reverse deps of packges that are currently processing+    -- All immediate reverse deps of packages that are currently processing     -- are not currently being processed (ie not in the processing set).     assert (and [ rdeppkgid `Set.notMember` processingSet                 | pkgid     <- Set.toList processingSet@@ -744,7 +744,7 @@  -- | Flatten an 'InstallPlan', producing the sequence of source packages in -- the order in which they would be processed when the plan is executed. This--- can be used for simultations or presenting execution dry-runs.+-- can be used for simulations or presenting execution dry-runs. -- -- It is guaranteed to give the same order as using 'execute' (with a serial -- in-order 'JobControl'), which is a reverse topological orderings of the
src/Distribution/Client/InstallSymlink.hs view
@@ -16,6 +16,7 @@     symlinkBinaries,     symlinkBinary,     trySymlink,+    promptRun   ) where  import Distribution.Client.Compat.Prelude hiding (ioError)@@ -62,6 +63,8 @@  import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) import Distribution.Client.Types.OverwritePolicy+import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) )+import Distribution.Client.Init.Prompt ( promptYesNo )  import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8@@ -191,16 +194,31 @@   ok <- targetOkToOverwrite (publicBindir </> publicName)                             (privateBindir </> privateName)   case ok of-    NotExists         ->           mkLink >> return True-    OkToOverwrite     -> rmLink >> mkLink >> return True+    NotExists         -> mkLink+    OkToOverwrite     -> overwrite     NotOurFile ->       case overwritePolicy of-        NeverOverwrite  ->                     return False-        AlwaysOverwrite -> rmLink >> mkLink >> return True+        NeverOverwrite  -> return False+        AlwaysOverwrite -> overwrite+        PromptOverwrite -> maybeOverwrite   where     relativeBindir = makeRelative publicBindir privateBindir-    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)-    rmLink = removeFile (publicBindir </> publicName)+    mkLink :: IO Bool+    mkLink = True <$ createFileLink (relativeBindir </> privateName) (publicBindir </> publicName)+    rmLink :: IO Bool+    rmLink = True <$ removeFile (publicBindir </> publicName)+    overwrite :: IO Bool+    overwrite = rmLink *> mkLink+    maybeOverwrite :: IO Bool+    maybeOverwrite+      = promptRun+        "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)"+        overwrite++promptRun :: String -> IO Bool -> IO Bool+promptRun s m = do+  a <- promptYesNo s MandatoryPrompt+  if a then m else pure a  -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or
src/Distribution/Client/List.hs view
@@ -192,7 +192,7 @@     notice verbosity "No packages requested. Nothing to do."  info verbosity packageDBs repoCtxt comp progdb-     globalFlags _listFlags userTargets = do+     _ _listFlags userTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt@@ -209,7 +209,6 @@                    ++ map packageId                       (PackageIndex.allPackages sourcePkgIndex)     pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)                        sourcePkgs' userTargets      pkgsinfo      <- sequenceA
src/Distribution/Client/Manpage.hs view
@@ -22,13 +22,19 @@  import Distribution.Client.Compat.Prelude import Prelude ()+import qualified Data.List.NonEmpty as List1 +import Distribution.Client.Init.Utils   (trim) import Distribution.Client.ManpageFlags import Distribution.Client.Setup        (globalCommand)-import Distribution.Compat.Process      (createProcess) import Distribution.Simple.Command import Distribution.Simple.Flag         (fromFlagOrDefault)+import Distribution.Simple.Utils+  ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut )+import qualified Distribution.Verbosity as Verbosity import System.IO                        (hClose, hPutStr)+import System.Environment               (lookupEnv)+import System.FilePath                  (takeFileName)  import qualified System.Process as Process @@ -42,7 +48,6 @@ files :: [FileInfo] files =   [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")-  , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")   ]  manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()@@ -50,24 +55,47 @@     | fromFlagOrDefault False (manpageRaw flags)     = putStrLn contents     | otherwise-    = do-        let cmd  = "man"-            args = ["-l", "-"]+    = ignoreSigPipe $ do+        -- 2021-10-08, issue #7714+        -- @cabal man --raw | man -l -@ does not work on macOS/BSD,+        -- because BSD-man does not support option @-l@, rather would+        -- accept directly a file argument, e.g. @man /dev/stdin@.+        -- The following works both on macOS and Linux+        -- (but not on Windows out-of-the-box):+        --+        --   cabal man --raw | nroff -man /dev/stdin | less+        --+        -- So let us simulate this! -        (mb_in, _, _, ph) <- createProcess (Process.proc cmd args)-            { Process.std_in  = Process.CreatePipe-            , Process.std_out = Process.Inherit-            , Process.std_err = Process.Inherit-            }+        -- Feed contents into @nroff -man /dev/stdin@+        (formatted, _errors, ec1) <- rawSystemStdInOut+          Verbosity.normal+          "nroff"+          [ "-man", "/dev/stdin" ]+          Nothing  -- Inherit working directory+          Nothing  -- Inherit environment+          (Just $ IODataText contents)+          IODataModeText -        -- put contents-        for_ mb_in $ \hin -> do-            hPutStr hin contents-            hClose hin+        unless (ec1 == ExitSuccess) $ exitWith ec1 -        -- wait for process to exit, propagate exit code-        ec <- Process.waitForProcess ph-        exitWith ec+        pager <- fromMaybe "less" <$> lookupEnv "PAGER"+        -- 'less' is borked with color sequences otherwise+        let pagerArgs = if takeFileName pager == "less" then ["-R"] else []+        -- Pipe output of @nroff@ into @less@+        (Just inLess, _, _, procLess) <- createProcessWithEnv+          Verbosity.normal+          pager+          pagerArgs+          Nothing  -- Inherit working directory+          Nothing  -- Inherit environment+          Process.CreatePipe  -- in+          Process.Inherit     -- out+          Process.Inherit     -- err++        hPutStr inLess formatted+        hClose  inLess+        exitWith =<< Process.waitForProcess procLess   where     contents :: String     contents = manpage pname commands@@ -118,7 +146,7 @@ commandSynopsisLines :: String -> CommandSpec action -> [String] commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =   [ ".B " ++ pname ++ " " ++ (commandName ui)-  , ".R - " ++ commandSynopsis ui+  , "- " ++ commandSynopsis ui   , ".br"   ] commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []@@ -130,8 +158,8 @@   , commandUsage ui pname   , ""   ] ++-  optional commandDescription ++-  optional commandNotes +++  optional removeLineBreaks commandDescription +++  optional id commandNotes ++   [ "Flags:"   , ".RS"   ] ++@@ -140,10 +168,26 @@   , ""   ]   where-    optional field =+    optional f field =       case field ui of-        Just text -> [text pname, ""]+        Just text -> [ f $ text pname, "" ]         Nothing   -> []+    -- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905+    -- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings.+    -- Thus:+    -- Remove line breaks but preserve paragraph breaks.+    -- We group lines by empty/non-empty and then 'unwords'+    -- blocks consisting of non-empty lines.+    removeLineBreaks+      = unlines+      . concatMap unwordsNonEmpty+      . List1.groupWith null+      . map trim+      . lines+    unwordsNonEmpty :: List1.NonEmpty String -> [String]+    unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls]+      where ls = List1.toList ls1+ commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []  optionsLines :: CommandUI flags -> [String]
− src/Distribution/Client/Outdated.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Outdated--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Implementation of the 'outdated' command. Checks for outdated--- dependencies in the package description file or freeze file.--------------------------------------------------------------------------------module Distribution.Client.Outdated ( outdated-                                    , ListOutdatedSettings(..), listOutdated )-where--import Prelude ()-import Distribution.Client.Config-import Distribution.Client.IndexUtils as IndexUtils-import Distribution.Client.Compat.Prelude-import Distribution.Client.ProjectConfig-import Distribution.Client.DistDirLayout-import Distribution.Client.RebuildMonad-import Distribution.Client.Setup hiding (quiet)-import Distribution.Client.Targets-import Distribution.Client.Types-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackageIndex-import Distribution.Client.Sandbox.PackageEnvironment-import Distribution.Utils.Generic--import Distribution.Package                          (PackageName, packageVersion)-import Distribution.PackageDescription               (allBuildDepends)-import Distribution.PackageDescription.Configuration (finalizePD)-import Distribution.Simple.Compiler                  (Compiler, compilerInfo)-import Distribution.Simple.Setup-       (fromFlagOrDefault, flagToMaybe)-import Distribution.Simple.Utils-       (die', notice, debug, tryFindPackageDesc)-import Distribution.System                           (Platform)-import Distribution.Types.ComponentRequestedSpec-       (ComponentRequestedSpec(..))-import Distribution.Types.Dependency-       (Dependency(..))-import Distribution.Verbosity                        (silent)-import Distribution.Version-       (Version, VersionInterval (..), VersionRange, LowerBound(..), UpperBound(..)-       ,asVersionIntervals, majorBoundVersion)-import Distribution.PackageDescription.Parsec-       (readGenericPackageDescription)-import Distribution.Types.PackageVersionConstraint-       (PackageVersionConstraint (..), simplifyPackageVersionConstraint)--import qualified Data.Set as S-import System.Directory                              (getCurrentDirectory)---- | Entry point for the 'outdated' command.-outdated :: Verbosity -> OutdatedFlags -> RepoContext-         -> Compiler -> Platform-         -> IO ()-outdated verbosity0 outdatedFlags repoContext comp platform = do-  let freezeFile    = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags)-      newFreezeFile = fromFlagOrDefault False-                      (outdatedNewFreezeFile outdatedFlags)-      mprojectFile  = flagToMaybe-                      (outdatedProjectFile outdatedFlags)-      simpleOutput  = fromFlagOrDefault False-                      (outdatedSimpleOutput outdatedFlags)-      quiet         = fromFlagOrDefault False (outdatedQuiet outdatedFlags)-      exitCode      = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags)-      ignorePred    = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags)-                      in \pkgname -> pkgname `S.member` ignoreSet-      minorPred     = case outdatedMinor outdatedFlags of-                        Nothing -> const False-                        Just IgnoreMajorVersionBumpsNone -> const False-                        Just IgnoreMajorVersionBumpsAll  -> const True-                        Just (IgnoreMajorVersionBumpsSome pkgs) ->-                          let minorSet = S.fromList pkgs-                          in \pkgname -> pkgname `S.member` minorSet-      verbosity     = if quiet then silent else verbosity0--  when (not newFreezeFile && isJust mprojectFile) $-    die' verbosity $-      "--project-file must only be used with --v2-freeze-file."--  sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext-  let pkgIndex = packageIndex sourcePkgDb-  deps <- if freezeFile-          then depsFromFreezeFile verbosity-          else if newFreezeFile-               then depsFromNewFreezeFile verbosity mprojectFile-               else depsFromPkgDesc verbosity comp platform-  debug verbosity $ "Dependencies loaded: "-    ++ (intercalate ", " $ map prettyShow deps)-  let outdatedDeps = listOutdated deps pkgIndex-                     (ListOutdatedSettings ignorePred minorPred)-  when (not quiet) $-    showResult verbosity outdatedDeps simpleOutput-  if (exitCode && (not . null $ outdatedDeps))-    then exitFailure-    else return ()---- | Print either the list of all outdated dependencies, or a message--- that there are none.-showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()-showResult verbosity outdatedDeps simpleOutput =-  if (not . null $ outdatedDeps)-    then-    do when (not simpleOutput) $-         notice verbosity "Outdated dependencies:"-       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->-         let outdatedDep = if simpleOutput then prettyShow pn-                           else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"-         in notice verbosity outdatedDep-    else notice verbosity "All dependencies are up to date."---- | Convert a list of 'UserConstraint's to a 'Dependency' list.-userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]-userConstraintsToDependencies ucnstrs =-  mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs---- | Read the list of dependencies from the freeze file.-depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]-depsFromFreezeFile verbosity = do-  cwd        <- getCurrentDirectory-  userConfig <- loadUserConfig verbosity cwd Nothing-  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $-                userConfig-      deps    = userConstraintsToDependencies ucnstrs-  debug verbosity "Reading the list of dependencies from the freeze file"-  return deps---- | Read the list of dependencies from the new-style freeze file.-depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint]-depsFromNewFreezeFile verbosity mprojectFile = do-  projectRoot <- either throwIO return =<<-                 findProjectRoot Nothing mprojectFile-  let distDirLayout = defaultDistDirLayout projectRoot-                      {- TODO: Support dist dir override -} Nothing-  projectConfig  <- runRebuild (distProjectRootDirectory distDirLayout) $-                    readProjectLocalFreezeConfig verbosity distDirLayout-  let ucnstrs = map fst . projectConfigConstraints . projectConfigShared-                $ projectConfig-      deps    = userConstraintsToDependencies ucnstrs-  debug verbosity $-    "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze"-  return deps---- | Read the list of dependencies from the package description.-depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint]-depsFromPkgDesc verbosity comp platform = do-  cwd  <- getCurrentDirectory-  path <- tryFindPackageDesc verbosity cwd-  gpd  <- readGenericPackageDescription verbosity path-  let cinfo = compilerInfo comp-      epd = finalizePD mempty (ComponentRequestedSpec True True)-            (const True) platform cinfo [] gpd-  case epd of-    Left _        -> die' verbosity "finalizePD failed"-    Right (pd, _) -> do-      let bd = allBuildDepends pd-      debug verbosity-        "Reading the list of dependencies from the package description"-      return $ map toPVC bd-  where-    toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr---- | Various knobs for customising the behaviour of 'listOutdated'.-data ListOutdatedSettings = ListOutdatedSettings {-  -- | Should this package be ignored?-  listOutdatedIgnorePred :: PackageName -> Bool,-  -- | Should major version bumps should be ignored for this package?-  listOutdatedMinorPred  :: PackageName -> Bool-  }---- | Find all outdated dependencies.-listOutdated :: [PackageVersionConstraint]-             -> PackageIndex UnresolvedSourcePackage-             -> ListOutdatedSettings-             -> [(PackageVersionConstraint, Version)]-listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =-  mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps-  where-    isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)-    isOutdated dep@(PackageVersionConstraint pname vr)-      | ignorePred pname = Nothing-      | otherwise                   =-          let this   = map packageVersion $ lookupDependency pkgIndex pname vr-              latest = lookupLatest dep-          in (\v -> (dep, v)) `fmap` isOutdated' this latest--    isOutdated' :: [Version] -> [Version] -> Maybe Version-    isOutdated' [] _  = Nothing-    isOutdated' _  [] = Nothing-    isOutdated' this latest =-      let this'   = maximum this-          latest' = maximum latest-      in if this' < latest' then Just latest' else Nothing--    lookupLatest :: PackageVersionConstraint -> [Version]-    lookupLatest (PackageVersionConstraint pname vr)-      | minorPred pname =-        map packageVersion $ lookupDependency pkgIndex  pname (relaxMinor vr)-      | otherwise =-        map packageVersion $ lookupPackageName pkgIndex pname--    relaxMinor :: VersionRange -> VersionRange-    relaxMinor vr =-      let vis = asVersionIntervals vr-      in maybe vr relax (safeLast vis)-      where relax (VersionInterval (LowerBound v0 _) upper) =-              case upper of-                NoUpperBound     -> vr-                UpperBound _v1 _ -> majorBoundVersion v0
src/Distribution/Client/PackageHash.hs view
@@ -34,7 +34,7 @@          ( FlagAssignment, showFlagAssignment ) import Distribution.Simple.Compiler          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)-         , ProfDetailLevel(..), showProfDetailLevel )+         , ProfDetailLevel(..), PackageDB, showProfDetailLevel ) import Distribution.Simple.InstallDirs          ( PathTemplate, fromPathTemplate ) import Distribution.Types.PkgconfigVersion (PkgconfigVersion)@@ -156,7 +156,7 @@   where     PackageIdentifier name version = pkgHashPkgId --- | All the information that contribues to a package's hash, and thus its+-- | All the information that contributes to a package's hash, and thus its -- 'InstalledPackageId'. -- data PackageHashInputs = PackageHashInputs {@@ -200,6 +200,7 @@        pkgHashExtraIncludeDirs    :: [FilePath],        pkgHashProgPrefix          :: Maybe PathTemplate,        pkgHashProgSuffix          :: Maybe PathTemplate,+       pkgHashPackageDbs          :: [Maybe PackageDB],         -- Haddock options        pkgHashDocumentation       :: Bool,@@ -293,6 +294,7 @@       , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs       , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix       , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix+      , opt   "package-dbs" [] (unwords . map show) pkgHashPackageDbs        , opt   "documentation"  False prettyShow pkgHashDocumentation       , opt   "haddock-hoogle" False prettyShow pkgHashHaddockHoogle
src/Distribution/Client/ParseUtils.hs view
@@ -172,7 +172,11 @@       case Map.lookup name fieldMap of         Just (FieldDescr _ _ set) -> set line value accum         Nothing -> do-          warning $ "Unrecognized field " ++ name ++ " on line " ++ show line+          -- the 'world-file' field was removed in 3.8, however+          -- it was automatically added to many config files+          -- before that, so its warning is silently ignored+          unless (name == "world-file") $+            warning $ "Unrecognized field " ++ name ++ " on line " ++ show line           return accum      setField accum f = do@@ -365,4 +369,3 @@ -- showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc showConfig = ppFieldsAndSections-
src/Distribution/Client/ProjectBuilding.hs view
@@ -68,7 +68,7 @@ import           Distribution.Client.SourceFiles import           Distribution.Client.SrcDist (allPackageSourceFiles) import           Distribution.Client.Utils-                   ( ProgressPhase(..), progressMessage, removeExistingFile )+                   ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile )  import           Distribution.Compat.Lens import           Distribution.Package@@ -97,11 +97,12 @@ import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS.Char8  import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))-import System.IO         (IOMode (AppendMode), withFile)+import System.IO         (IOMode (AppendMode), Handle, withFile)  import Distribution.Compat.Directory (listDirectory) @@ -230,6 +231,7 @@             then dryRunLocalPkg pkg depsBuildStatus srcdir             else return (BuildStatusUnpack tarball)       where+        srcdir :: FilePath         srcdir = distUnpackedSrcDirectory (packageId pkg)      dryRunLocalPkg :: ElaboratedConfiguredPackage@@ -250,6 +252,7 @@           Right buildResult ->             return (BuildStatusUpToDate buildResult)       where+        packageFileMonitor :: PackageFileMonitor         packageFileMonitor =           newPackageFileMonitor shared distDirLayout           (elabDistDirParams shared pkg)@@ -295,6 +298,7 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus =     InstallPlan.installed canPackageBeImproved   where+    canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool     canPackageBeImproved pkg =       case Map.lookup (installedUnitId pkg) pkgsBuildStatus of         Just BuildStatusUpToDate {} -> True@@ -376,6 +380,13 @@     -- do not affect the configure step need to be nulled out. Those parts are     -- the specific targets that we're going to build.     --++    -- Additionally we null out the parts that don't affect the configure step because they're simply+    -- about how tests or benchmarks are run++    -- TODO there may be more things to null here too, in the future.++    elab_config :: ElaboratedConfiguredPackage     elab_config =         elab {             elabBuildTargets   = [],@@ -383,13 +394,21 @@             elabBenchTargets   = [],             elabReplTarget     = Nothing,             elabHaddockTargets = [],-            elabBuildHaddocks  = False+            elabBuildHaddocks  = False,++            elabTestMachineLog   = Nothing,+            elabTestHumanLog     = Nothing,+            elabTestShowDetails  = Nothing,+            elabTestKeepTix      = False,+            elabTestTestOptions  = [],+            elabBenchmarkOptions = []         }      -- The second part is the value used to guard the build step. So this is     -- more or less the opposite of the first part, as it's just the info about     -- what targets we're going to build.     --+    buildComponents :: Set ComponentName     buildComponents = elabBuildTargetWholeComponents elab  -- | Do all the checks on whether a package has changed and thus needs either@@ -464,6 +483,7 @@                   (docsResult, testsResult) = buildResult   where     (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg+    changedToMaybe :: MonitorChanged a b -> Maybe b     changedToMaybe (MonitorChanged     _) = Nothing     changedToMaybe (MonitorUnchanged x _) = Just x @@ -579,7 +599,7 @@     createDirectoryIfMissingVerbose verbosity True distTempDirectory     traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse -    -- Before traversing the install plan, pre-emptively find all packages that+    -- Before traversing the install plan, preemptively find all packages that     -- will need to be downloaded and start downloading them.     asyncDownloadPackages verbosity withRepoCtx                           installPlan pkgsBuildStatus $ \downloadMap ->@@ -681,6 +701,7 @@   where     unexpectedState = error "rebuildTarget: unexpected package status" +    downloadPhase :: IO BuildResult     downloadPhase = do         downsrcloc <- annotateFailureNoLog DownloadFailed $                         waitAsyncPackageDownload verbosity downloadMap pkg@@ -689,6 +710,7 @@           --TODO: [nice to have] git/darcs repos etc  +    unpackTarballPhase :: FilePath -> IO BuildResult     unpackTarballPhase tarball =         withTarballLocalDirectory           verbosity distDirLayout tarball@@ -706,6 +728,7 @@     -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages     -- would only start from download or unpack phases.     --+    rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult     rebuildPhase buildStatus srcdir =         assert (elabBuildStyle pkg == BuildInplaceOnly) $ @@ -714,6 +737,7 @@         builddir = distBuildDirectory                    (elabDistDirParams sharedPackageConfig pkg) +    buildAndInstall :: FilePath -> FilePath -> IO BuildResult     buildAndInstall srcdir builddir =         buildAndInstallUnpackedPackage           verbosity distDirLayout storeDirLayout@@ -725,6 +749,7 @@         builddir' = makeRelative srcdir builddir         --TODO: [nice to have] ^^ do this relative stuff better +    buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult     buildInplace buildStatus srcdir builddir =         --TODO: [nice to have] use a relative build dir rather than absolute         buildInplaceUnpackedPackage@@ -760,6 +785,7 @@                             asyncFetchPackages verbosity repoctx                                                pkgsToDownload body   where+    pkgsToDownload :: [PackageLocation (Maybe FilePath)]     pkgsToDownload =       ordNub $       [ elabPkgSourceLocation elab@@ -883,6 +909,7 @@           writeFileAtomic cabalFile pkgtxt    where+    cabalFile :: FilePath     cabalFile = parentdir </> pkgsubdir                           </> prettyShow pkgname <.> "cabal"     pkgsubdir = prettyShow pkgid@@ -892,8 +919,8 @@ -- | This is a bit of a hacky workaround. A number of packages ship -- pre-processed .hs files in a dist directory inside the tarball. We don't -- use the standard 'dist' location so unless we move this dist dir to the--- right place then we'll miss the shipped pre-procssed files. This hacky--- approach to shipped pre-procssed files ought to be replaced by a proper+-- right place then we'll miss the shipped pre-processed files. This hacky+-- approach to shipped pre-processed files ought to be replaced by a proper -- system, though we'll still need to keep this hack for older packages. -- moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout@@ -990,10 +1017,19 @@             -- https://github.com/haskell/cabal/issues/4130             createDirectoryIfMissingVerbose verbosity True entryDir -            LBS.writeFile-              (entryDir </> "cabal-hash.txt")-              (renderPackageHashInputs (packageHashInputs pkgshared pkg))+            let hashFileName     = entryDir </> "cabal-hash.txt"+                outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) +            info verbosity $+              "creating file with the inputs used to compute the package hash: " ++ hashFileName++            LBS.writeFile hashFileName outPkgHashInputs++            debug verbosity "Package hash inputs:"+            traverse_+              (debug verbosity . ("> " ++))+              (lines $ LBS.Char8.unpack outPkgHashInputs)+             -- Ensure that there are no files in `tmpDir`, that are             -- not in `entryDir`. While this breaks the             -- prefix-relocatable property of the libraries, it is@@ -1076,12 +1112,14 @@     uid    = installedUnitId rpkg     compid = compilerId compiler +    dispname :: String     dispname = case elabPkgOrComp pkg of         ElabPackage _ -> prettyShow pkgid             ++ " (all, legacy fallback)"         ElabComponent comp -> prettyShow pkgid             ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" +    noticeProgress :: ProgressPhase -> IO ()     noticeProgress phase = when isParallelBuild $         progressMessage verbosity phase dispname @@ -1143,6 +1181,7 @@         Nothing        -> Nothing         Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) +    initLogFile :: IO ()     initLogFile =       case mlogFile of         Nothing      -> return ()@@ -1151,6 +1190,7 @@           exists <- doesFileExist logFile           when exists $ removeFile logFile +    withLogging :: (Maybe Handle -> IO r) -> IO r     withLogging action =       case mlogFile of         Nothing      -> action Nothing@@ -1162,6 +1202,7 @@   | not elabBuildHaddocks = False   | otherwise             = any componentHasHaddocks components   where+    components :: [ComponentTarget]     components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets               ++ maybeToList elabReplTarget ++ elabHaddockTargets @@ -1193,11 +1234,12 @@                               distPackageCacheDirectory,                               distDirectory                             }-                            BuildTimeSettings{buildSettingNumJobs}+                            BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}                             registerLock cacheLock                             pkgshared@ElaboratedSharedConfig {                               pkgConfigCompiler      = compiler,-                              pkgConfigCompilerProgs = progdb+                              pkgConfigCompilerProgs = progdb,+                              pkgConfigPlatform      = platform                             }                             plan                             rpkg@(ReadyPackage pkg)@@ -1313,6 +1355,17 @@               Tar.createTarGzFile dest docDir name               notice verbosity $ "Documentation tarball created: " ++ dest +            when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do+              let dest = docDir </> name </> "index.html"+                  name = haddockDirName haddockTarget (elabPkgDescription pkg)+                  docDir = distBuildDirectory distDirLayout dparams+                           </> "doc" </> "html"+              exe <- findOpenProgramLocation platform+              case exe of+                Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])+                Left err -> die' verbosity err++         return BuildResult {           buildResultDocs    = docsResult,           buildResultTests   = testsResult,@@ -1447,6 +1500,7 @@       "Couldn't parse the output of 'setup register --gen-pkg-config':"       ++ show perror +    readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo     readPkgConf pkgConfDir pkgConfFile = do       pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)       (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
src/Distribution/Client/ProjectConfig.hs view
@@ -27,7 +27,9 @@     -- * Project config files     readProjectConfig,     readGlobalConfig,+    readProjectLocalExtraConfig,     readProjectLocalFreezeConfig,+    reportParseResult,     showProjectConfig,     withProjectOrGlobalConfig,     writeProjectLocalExtraConfig,@@ -310,7 +312,6 @@     --buildSettingLogVerbosity  -- defined below, more complicated     buildSettingBuildReports  = fromFlag    projectConfigBuildReports     buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir-    buildSettingOneShot       = fromFlag    projectConfigOneShot     buildSettingNumJobs       = determineNumJobs projectConfigNumJobs     buildSettingKeepGoing     = fromFlag    projectConfigKeepGoing     buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode@@ -323,6 +324,7 @@     buildSettingReportPlanningFailure                               = fromFlag projectConfigReportPlanningFailure     buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra+    buildSettingHaddockOpen   = False      ProjectConfigBuildOnly{..} = defaults                               <> projectConfigBuildOnly@@ -334,7 +336,6 @@       projectConfigBuildReports          = toFlag NoReports,       projectConfigReportPlanningFailure = toFlag False,       projectConfigKeepGoing             = toFlag False,-      projectConfigOneShot               = toFlag False,       projectConfigOfflineMode           = toFlag False,       projectConfigKeepTempFiles         = toFlag False,       projectConfigIgnoreExpiry          = toFlag False@@ -378,10 +379,12 @@     -- If the user has specified --remote-build-reporting=detailed or     -- --build-log, use more verbose logging.     --+    buildSettingLogVerbosity :: Verbosity     buildSettingLogVerbosity       | overrideVerbosity = modifyVerbosity (max verbose) verbosity       | otherwise         = verbosity +    overrideVerbosity :: Bool     overrideVerbosity       | buildSettingBuildReports == DetailedReports = True       | isJust givenTemplate                        = True@@ -417,12 +420,15 @@     homedir  <- getHomeDirectory     probe startdir homedir   where+    projectFileName :: String     projectFileName = fromMaybe "cabal.project" mprojectFile      -- Search upwards. If we get to the users home dir or the filesystem root,     -- then use the current dir+    probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot)     probe startdir homedir = go startdir       where+        go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)         go dir | isDrive dir || dir == homedir =           case mprojectFile of             Nothing   -> return (Right (ProjectRootImplicit startdir))@@ -456,7 +462,7 @@  withProjectOrGlobalConfig     :: Verbosity                  -- ^ verbosity-    -> Flag Bool                  -- ^ whether to ignore local project+    -> Flag Bool                  -- ^ whether to ignore local project (--ignore-project flag)     -> Flag FilePath              -- ^ @--cabal-config@     -> IO a                       -- ^ with project     -> (ProjectConfig -> IO a)    -- ^ without projet@@ -497,77 +503,82 @@ -- file if any, plus other global config. -- readProjectConfig :: Verbosity+                  -> HttpTransport+                  -> Flag Bool -- ^ @--ignore-project@                   -> Flag FilePath                   -> DistDirLayout-                  -> Rebuild ProjectConfig-readProjectConfig verbosity configFileFlag distDirLayout = do-    global <- readGlobalConfig                verbosity configFileFlag-    local  <- readProjectLocalConfigOrDefault verbosity distDirLayout-    freeze <- readProjectLocalFreezeConfig    verbosity distDirLayout-    extra  <- readProjectLocalExtraConfig     verbosity distDirLayout-    return (global <> local <> freeze <> extra)-+                  -> Rebuild ProjectConfigSkeleton+readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do+    global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag+    local  <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout+    freeze <- readProjectLocalFreezeConfig    verbosity httpTransport distDirLayout+    extra  <- readProjectLocalExtraConfig     verbosity httpTransport distDirLayout+    if ignoreProjectFlag == Flag True then return (global <> (singletonProjectConfigSkeleton defaultProject))+    else return (global <> local <> freeze <> extra)+    where+      defaultProject :: ProjectConfig+      defaultProject = mempty {+        projectPackages = ["./"]+      }  -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. -- readProjectLocalConfigOrDefault :: Verbosity+                                -> HttpTransport                                 -> DistDirLayout-                                -> Rebuild ProjectConfig-readProjectLocalConfigOrDefault verbosity distDirLayout = do+                                -> Rebuild ProjectConfigSkeleton+readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do   usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile   if usesExplicitProjectRoot     then do-      readProjectFile verbosity distDirLayout "" "project file"+      readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file"     else do       monitorFiles [monitorNonExistentFile projectFile]-      return defaultImplicitProjectConfig+      return (singletonProjectConfigSkeleton defaultImplicitProjectConfig)    where+    projectFile :: FilePath     projectFile = distProjectFile distDirLayout ""-     defaultImplicitProjectConfig :: ProjectConfig-    defaultImplicitProjectConfig =-      mempty {-        -- We expect a package in the current directory.-        projectPackages         = [ "./*.cabal" ],+    defaultImplicitProjectConfig = mempty {+      -- We expect a package in the current directory.+      projectPackages         = [ "./*.cabal" ], -        projectConfigProvenance = Set.singleton Implicit-      }+      projectConfigProvenance = Set.singleton Implicit+    }  -- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. ---readProjectLocalExtraConfig :: Verbosity -> DistDirLayout-                            -> Rebuild ProjectConfig-readProjectLocalExtraConfig verbosity distDirLayout =-    readProjectFile verbosity distDirLayout "local"+readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout+                            -> Rebuild ProjectConfigSkeleton+readProjectLocalExtraConfig verbosity httpTransport distDirLayout =+    readProjectFileSkeleton verbosity httpTransport distDirLayout "local"                              "project local configuration file"  -- | Reads a @cabal.project.freeze@ file in the given project root dir, -- or returns empty. This file gets written by @cabal freeze@, or in -- principle can be edited manually or by other tools. ---readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout-                             -> Rebuild ProjectConfig-readProjectLocalFreezeConfig verbosity distDirLayout =-    readProjectFile verbosity distDirLayout "freeze"+readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout+                             -> Rebuild ProjectConfigSkeleton+readProjectLocalFreezeConfig verbosity httpTransport distDirLayout =+    readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze"                              "project freeze file" --- | Reads a named config file in the given project root dir, or returns empty.+-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. ---readProjectFile :: Verbosity-                -> DistDirLayout-                -> String-                -> String-                -> Rebuild ProjectConfig-readProjectFile verbosity DistDirLayout{distProjectFile}+readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton+readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory}                          extensionName extensionDescription = do     exists <- liftIO $ doesFileExist extensionFile     if exists       then do monitorFiles [monitorFileHashed extensionFile]-              addProjectFileProvenance <$> liftIO readExtensionFile+              pcs <- liftIO readExtensionFile+              monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)+              pure pcs       else do monitorFiles [monitorNonExistentFile extensionFile]               return mempty   where@@ -575,27 +586,9 @@      readExtensionFile =           reportParseResult verbosity extensionDescription extensionFile-        . (parseProjectConfig extensionFile)+      =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile       =<< BS.readFile extensionFile -    addProjectFileProvenance config =-      config {-        projectConfigProvenance =-          Set.insert (Explicit extensionFile) (projectConfigProvenance config)-      }----- | Parse the 'ProjectConfig' format.------ For the moment this is implemented in terms of parsers for legacy--- configuration types, plus a conversion.----parseProjectConfig :: FilePath -> BS.ByteString -> OldParser.ParseResult ProjectConfig-parseProjectConfig source content =-    convertLegacyProjectConfig <$>-      (parseLegacyProjectConfig source content)-- -- | Render the 'ProjectConfig' format. -- -- For the moment this is implemented in terms of a pretty printer for the@@ -636,12 +629,12 @@     monitorFiles [monitorFileHashed configFile]     return (convertLegacyGlobalConfig config) -reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a+reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do-    unless (null warnings) $-      let msg = unlines (map (OldParser.showPWarning filename) warnings)+   unless (null warnings) $+      let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)        in warn verbosity msg-    return x+   return x reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =     let (line, msg) = OldParser.locatedErrorMsg err      in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename@@ -807,6 +800,7 @@      return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])   where+    findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]     findPackageLocations required pkglocstr = do       (problems, pkglocs) <-         partitionEithers <$> traverse (findPackageLocation required) pkglocstr@@ -1106,8 +1100,10 @@              . uncurry (readSourcePackageCabalFile verbosity)            =<< extractTarballPackageCabalFile tarballFile   where+    tarballStem :: FilePath     tarballStem = distDownloadSrcDirectory               </> localFileNameForRemoteTarball tarballUri+    tarballFile :: FilePath     tarballFile = tarballStem <.> "tar.gz"      monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))@@ -1180,7 +1176,7 @@         for_ repoGroupWithPaths $ \(repo, _, repoPath) ->             for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do                 exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing-                unless (exitCode /= ExitSuccess) $ exitWith exitCode+                unless (exitCode == ExitSuccess) $ exitWith exitCode          -- But for reading we go through each 'SourceRepo' including its subdir         -- value and have to know which path each one ended up in.@@ -1268,7 +1264,7 @@     [PWarning]         -- ^ warnings   deriving (Typeable) --- | Manual instance which skips file contentes+-- | Manual instance which skips file contents instance Show CabalFileParseError where     showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10)         $ showString "CabalFileParseError"
src/Distribution/Client/ProjectConfig/Legacy.hs view
@@ -1,9 +1,16 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds, FlexibleInstances #-}  -- | Project configuration, implementation in terms of legacy types. -- module Distribution.Client.ProjectConfig.Legacy ( +   -- Project config skeletons+    ProjectConfigSkeleton,+    parseProjectSkeleton,+    instantiateProjectConfigSkeleton,+    singletonProjectConfigSkeleton,+    projectSkeletonImports,+     -- * Project config in terms of legacy types     LegacyProjectConfig,     parseLegacyProjectConfig,@@ -17,13 +24,12 @@      -- * Internals, just for tests     parsePackageLocationTokenQ,-    renderPackageLocationToken,+    renderPackageLocationToken   ) where -import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Types.Flag (parsecFlagAssignment)+import Distribution.Types.Flag (parsecFlagAssignment, FlagName)  import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)@@ -38,23 +44,29 @@          ( ClientInstallFlags(..), defaultClientInstallFlags          , clientInstallOptions ) +import Distribution.Compat.Lens (view)+ import Distribution.Solver.Types.ConstraintSource  import Distribution.FieldGrammar import Distribution.Package import Distribution.Types.SourceRepo (RepoType)+import Distribution.Types.CondTree+         ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC ) import Distribution.PackageDescription-         ( dispFlagAssignment )+         ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment )+import Distribution.PackageDescription.Configuration (simplifyWithSysParams) import Distribution.Simple.Compiler-         ( OptimisationLevel(..), DebugInfoLevel(..) )+         ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) ) import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) import Distribution.Simple.Setup-         ( Flag(Flag), toFlag, fromFlagOrDefault+         ( Flag(..), toFlag, fromFlagOrDefault          , ConfigFlags(..), configureOptions          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , TestFlags(..), testOptions', defaultTestFlags          , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags-         , programDbPaths', splitArgs+         , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo)+         , readPackageDb, showPackageDb          ) import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)@@ -84,7 +96,7 @@          ( ParseResult(..), PError(..), syntaxError, PWarning(..)          , commaNewLineListFieldParsec, newLineListField, parseTokenQ          , parseHaskellString, showToken-         , simpleFieldParsec+         , simpleFieldParsec, parseFail          ) import Distribution.Client.ParseUtils import Distribution.Simple.Command@@ -92,14 +104,133 @@          , OptionField, option, reqArg' ) import Distribution.Types.PackageVersionConstraint          ( PackageVersionConstraint )-import Distribution.Parsec (ParsecParser)+import Distribution.Parsec (ParsecParser, parsecToken)+import Distribution.System (OS, Arch)  import qualified Data.Map as Map-import qualified Data.ByteString as BS+import qualified Data.Set as Set+import qualified Data.ByteString.Char8 as BS -import Network.URI (URI (..))+import Network.URI (URI (..), parseURI) +import Distribution.Fields.ConfVar (parseConditionConfVarFromClause)++import Distribution.Client.HttpUtils+import System.FilePath ((</>), isPathSeparator, makeValid)+import System.Directory (createDirectoryIfMissing)++++ ------------------------------------------------------------------+-- Handle extended project config files with conditionals and imports.+--++-- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info+-- and then resolving and downloading the imports+type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigImport] ProjectConfig+type ProjectConfigImport = String+++singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton+singletonProjectConfigSkeleton x = CondNode x mempty mempty++instantiateProjectConfigSkeleton :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig+instantiateProjectConfigSkeleton os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel+    where+        go :: CondTree+               FlagName+               [ProjectConfigImport]+               ProjectConfig+             -> ProjectConfig+        go (CondNode l _imps ts) =+           let branches = concatMap processBranch ts+           in l <> mconcat branches+        processBranch (CondBranch cnd t mf) = case cnd of+           (Lit True) ->  [go t]+           (Lit False) -> maybe ([]) ((:[]) . go) mf+           _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer++projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport]+projectSkeletonImports = view traverseCondTreeC++parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfigImport] -> FilePath -> BS.ByteString -> IO (ParseResult ProjectConfigSkeleton)+parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs)+  where+    go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton)+    go acc (x:xs) = case x of+         (ParseUtils.F l "import" importLoc) ->+            if importLoc `elem` seenImports+              then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l)+              else do+                let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc)+                res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc+                rest <- go [] xs+                pure . fmap mconcat . sequence $ [fs, res, rest]+         (ParseUtils.Section l "if" p xs') -> do+                subpcs <- go [] xs'+                let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc)+                (elseClauses, rest) <- parseElseClauses xs+                let condNode =  (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>+                      -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused+                      adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") <*>+                      subpcs <*>+                      elseClauses+                pure . fmap mconcat . sequence $ [fs, condNode, rest]+         _ -> go (x:acc) xs+    go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc++    parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton)+    parseElseClauses x = case x of+         (ParseUtils.Section _l "else" _p xs':xs) -> do+               subpcs <- go [] xs'+               rest <- go [] xs+               pure (Just <$> subpcs, rest)+         (ParseUtils.Section l "elif" p xs':xs) -> do+               subpcs <- go [] xs'+               (elseClauses, rest) <- parseElseClauses xs+               let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>+                                  adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else("<> p <> ")") <*>+                                  subpcs <*>+                                  elseClauses+               pure (Just <$> condNode, rest)+         _ -> (\r -> (pure Nothing,r)) <$> go [] x++    fieldsToConfig xs = fmap (addProvenance . convertLegacyProjectConfig) $ parseLegacyProjectConfigFields source xs+    addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)}++    adaptParseError _ (Right x) = pure x+    adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l)++    liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b)+    liftPR f (ParseOk ws x) = addWarnings <$> f x+       where addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x'+             addWarnings x' = x'+    liftPR _ (ParseFailed e) = pure $ ParseFailed e++    fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString+    fetchImportConfig pci = case parseURI pci of+         Just uri -> do+            let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)+            createDirectoryIfMissing True cacheDir+            _ <- downloadURI httpTransport verbosity uri fp+            BS.readFile fp+         Nothing -> BS.readFile pci++    modifiesCompiler :: ProjectConfig -> Bool+    modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg+      where+         isSet f = f (projectConfigShared pc) /= NoFlag++    sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton+    sanityWalkPCS underConditional t@(CondNode d _c comps)+           | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing+           | otherwise = mapM_ sanityWalkBranch comps >> pure t++    sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult ()+    sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()++------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- @@ -197,7 +328,7 @@         -- split the package config (from command line arguments) into         -- those applied to all packages and those to local only.         ---        -- for now we will just copy over the ProgramPaths/Args/Extra into+        -- for now we will just copy over the ProgramPaths/Extra into         -- the AllPackages.  The LocalPackages do not inherit them from         -- AllPackages, and as such need to retain them.         --@@ -214,7 +345,6 @@         splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)         splitConfig pc = (pc                          , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc-                                  , packageConfigProgramArgs  = packageConfigProgramArgs  pc                                   , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc                                   , packageConfigDocumentation = packageConfigDocumentation pc }) @@ -352,11 +482,11 @@       configDistPref            = projectConfigDistDir,       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,-      configHcPkg               = projectConfigHcPkg+      configHcPkg               = projectConfigHcPkg,     --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME     --configInstallDirs         = projectConfigInstallDirs,     --configUserInstall         = projectConfigUserInstall,-    --configPackageDBs          = projectConfigPackageDBs,+      configPackageDBs          = projectConfigPackageDBs     } = configFlags      ConfigExFlags {@@ -428,6 +558,7 @@       configStripExes           = packageConfigStripExes,       configStripLibs           = packageConfigStripLibs,       configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraLibDirsStatic  = packageConfigExtraLibDirsStatic,       configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,       configConfigurationsFlags = packageConfigFlagAssignment,@@ -436,6 +567,7 @@       configCoverage            = coverage,       configLibCoverage         = libcoverage, --deprecated       configDebugInfo           = packageConfigDebugInfo,+      configDumpBuildInfo       = packageConfigDumpBuildInfo,       configRelocatable         = packageConfigRelocatable     } = configFlags     packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)@@ -498,7 +630,6 @@     GlobalFlags {       globalCacheDir          = projectConfigCacheDir,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = _,       globalHttpTransport     = projectConfigHttpTransport,       globalIgnoreExpiry      = projectConfigIgnoreExpiry     } = globalFlags@@ -518,7 +649,6 @@       installBuildReports       = projectConfigBuildReports,       installReportPlanningFailure = projectConfigReportPlanningFailure,       installSymlinkBinDir      = projectConfigSymlinkBinDir,-      installOneShot            = projectConfigOneShot,       installNumJobs            = projectConfigNumJobs,       installKeepGoing          = projectConfigKeepGoing,       installOfflineMode        = projectConfigOfflineMode@@ -584,7 +714,6 @@       globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,       globalActiveRepos       = projectConfigActiveRepos,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = mempty,       globalIgnoreExpiry      = projectConfigIgnoreExpiry,       globalHttpTransport     = projectConfigHttpTransport,       globalNix               = mempty,@@ -594,11 +723,14 @@      configFlags = mempty {       configVerbosity     = projectConfigVerbosity,-      configDistPref      = projectConfigDistDir+      configDistPref      = projectConfigDistDir,+      configPackageDBs    = projectConfigPackageDBs     }      configExFlags = ConfigExFlags {       configCabalVersion  = projectConfigCabalVersion,+      configAppend        = mempty,+      configBackup        = mempty,       configExConstraints = projectConfigConstraints,       configPreferences   = projectConfigPreferences,       configSolver        = projectConfigSolver,@@ -638,7 +770,6 @@       installReportPlanningFailure = projectConfigReportPlanningFailure,       installSymlinkBinDir     = projectConfigSymlinkBinDir,       installPerComponent      = projectConfigPerComponent,-      installOneShot           = projectConfigOneShot,       installNumJobs           = projectConfigNumJobs,       installKeepGoing         = projectConfigKeepGoing,       installRunTests          = mempty,@@ -696,13 +827,14 @@       configCabalFilePath       = mempty,       configVerbosity           = mempty,       configUserInstall         = mempty, --projectConfigUserInstall,-      configPackageDBs          = mempty, --projectConfigPackageDBs,+      configPackageDBs          = mempty,       configGHCiLib             = mempty,       configSplitSections       = mempty,       configSplitObjs           = mempty,       configStripExes           = mempty,       configStripLibs           = mempty,       configExtraLibDirs        = mempty,+      configExtraLibDirsStatic  = mempty,       configExtraFrameworkDirs  = mempty,       configConstraints         = mempty,       configDependencies        = mempty,@@ -720,6 +852,7 @@       configRelocatable         = mempty,       configDebugInfo           = mempty,       configUseResponseFiles    = mempty,+      configDumpBuildInfo       = mempty,       configAllowDependingOnPrivateLibs = mempty     } @@ -775,6 +908,7 @@       configStripExes           = packageConfigStripExes,       configStripLibs           = packageConfigStripLibs,       configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraLibDirsStatic  = packageConfigExtraLibDirsStatic,       configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,       configConstraints         = mempty,       configDependencies        = mempty,@@ -792,6 +926,7 @@       configRelocatable         = packageConfigRelocatable,       configDebugInfo           = packageConfigDebugInfo,       configUseResponseFiles    = mempty,+      configDumpBuildInfo       = packageConfigDumpBuildInfo,       configAllowDependingOnPrivateLibs = mempty     } @@ -846,15 +981,18 @@ -- Parsing and showing the project config file -- -parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig-parseLegacyProjectConfig source =-    parseConfig (legacyProjectConfigFieldDescrs constraintSrc)+parseLegacyProjectConfigFields :: FilePath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig+parseLegacyProjectConfigFields source =+    parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc)                 legacyPackageConfigSectionDescrs                 legacyPackageConfigFGSectionDescrs                 mempty   where     constraintSrc = ConstraintSourceProjectConfig source +parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig+parseLegacyProjectConfig source bs = parseLegacyProjectConfigFields source =<< ParseUtils.readFields bs+ showLegacyProjectConfig :: LegacyProjectConfig -> String showLegacyProjectConfig config =     Disp.render $@@ -972,6 +1110,11 @@   , liftFields       legacyConfigureShFlags       (\flags conf -> conf { legacyConfigureShFlags = flags })+  . addFields+      [ commaNewLineListFieldParsec "package-dbs"+        (Disp.text . showPackageDb) (fmap readPackageDb parsecToken)+        configPackageDBs (\v conf -> conf { configPackageDBs = v })+      ]   . filterFields ["verbose", "builddir" ]   . commandOptionsToFields   $ configureOptions ParseArgs@@ -1019,7 +1162,7 @@       , "root-cmd", "symlink-bindir"       , "build-log"       , "remote-build-reporting", "report-planning-failure"-      , "one-shot", "jobs", "keep-going", "offline", "per-component"+      , "jobs", "keep-going", "offline", "per-component"         -- solver flags:       , "max-backjumps", "reorder-goals", "count-conflicts"       , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals"@@ -1058,6 +1201,10 @@           showTokenQ parseTokenQ           configExtraLibDirs           (\v conf -> conf { configExtraLibDirs = v })+      , newLineListField "extra-lib-dirs-static"+          showTokenQ parseTokenQ+          configExtraLibDirsStatic+          (\v conf -> conf { configExtraLibDirsStatic = v })       , newLineListField "extra-framework-dirs"           showTokenQ parseTokenQ           configExtraFrameworkDirs@@ -1074,6 +1221,7 @@           dispFlagAssignment parsecFlagAssignment           configConfigurationsFlags           (\v conf -> conf { configConfigurationsFlags = v })+      , overrideDumpBuildInfo       ]   . filterFields       [ "with-compiler", "with-hc-pkg"@@ -1171,6 +1319,23 @@         (toFlag <$> parsec <|> pure mempty)         configHcFlavor (\v flags -> flags { configHcFlavor = v }) +    overrideDumpBuildInfo =+      liftField configDumpBuildInfo+                (\v flags -> flags { configDumpBuildInfo = v }) $+      let name = "build-info" in+      FieldDescr name+        (\f -> case f of+                 Flag NoDumpBuildInfo -> Disp.text "False"+                 Flag DumpBuildInfo   -> Disp.text "True"+                 _                    -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoDumpBuildInfo)+           |  str == "True"  -> ParseOk [] (Flag DumpBuildInfo)+           | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo)+           | lstr == "true"  -> ParseOk [caseWarning name] (Flag DumpBuildInfo)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str)      -- TODO: [code cleanup] The following is a hack. The "optimization" and     -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.@@ -1193,13 +1358,11 @@            |  str == "0"     -> ParseOk [] (Flag NoOptimisation)            |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)            |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)-           | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)-           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)+           | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation)+           | lstr == "true"  -> ParseOk [caseWarning name] (Flag NormalOptimisation)            | otherwise       -> ParseFailed (NoParse name line)            where-             lstr = lowercase str-             caseWarning = PWarning $-               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+             lstr = lowercase str)      overrideFieldDebugInfo =       liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $@@ -1218,13 +1381,14 @@            |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)            |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)            |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)-           | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)-           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+           | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo)+           | lstr == "true"  -> ParseOk [caseWarning name] (Flag NormalDebugInfo)            | otherwise       -> ParseFailed (NoParse name line)            where-             lstr = lowercase str-             caseWarning = PWarning $-               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+             lstr = lowercase str)++    caseWarning name = PWarning $+      "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."      prefixTest name | "test-" `isPrefixOf` name = name                     | otherwise = "test-" ++ name
src/Distribution/Client/ProjectConfig/Types.hs view
@@ -56,10 +56,10 @@ import Distribution.PackageDescription          ( FlagAssignment ) import Distribution.Simple.Compiler-         ( Compiler, CompilerFlavor+         ( Compiler, CompilerFlavor, PackageDB          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup-         ( Flag, HaddockTarget(..), TestShowDetails(..) )+         ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) ) import Distribution.Simple.InstallDirs          ( PathTemplate ) import Distribution.Utils.NubList@@ -142,7 +142,6 @@        projectConfigBuildReports          :: Flag ReportLevel,        projectConfigReportPlanningFailure :: Flag Bool,        projectConfigSymlinkBinDir         :: Flag FilePath,-       projectConfigOneShot               :: Flag Bool,        projectConfigNumJobs               :: Flag (Maybe Int),        projectConfigKeepGoing             :: Flag Bool,        projectConfigOfflineMode           :: Flag Bool,@@ -176,7 +175,7 @@      --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),      --TODO: [required eventually] decide what to do with InstallDirs      -- currently we don't allow it to be specified in the config file-     --projectConfigPackageDBs        :: [Maybe PackageDB],+       projectConfigPackageDBs        :: [Maybe PackageDB],         -- configuration used both by the solver and other phases        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.@@ -258,6 +257,7 @@        packageConfigProgPrefix          :: Flag PathTemplate,        packageConfigProgSuffix          :: Flag PathTemplate,        packageConfigExtraLibDirs        :: [FilePath],+       packageConfigExtraLibDirsStatic  :: [FilePath],        packageConfigExtraFrameworkDirs  :: [FilePath],        packageConfigExtraIncludeDirs    :: [FilePath],        packageConfigGHCiLib             :: Flag Bool,@@ -270,6 +270,7 @@        packageConfigCoverage            :: Flag Bool,        packageConfigRelocatable         :: Flag Bool,        packageConfigDebugInfo           :: Flag DebugInfoLevel,+       packageConfigDumpBuildInfo       :: Flag DumpBuildInfo,        packageConfigRunTests            :: Flag Bool, --TODO: [required eventually] use this        packageConfigDocumentation       :: Flag Bool, --TODO: [required eventually] use this        -- Haddock options@@ -446,7 +447,6 @@        buildSettingBuildReports          :: ReportLevel,        buildSettingReportPlanningFailure :: Bool,        buildSettingSymlinkBinDir         :: [FilePath],-       buildSettingOneShot               :: Bool,        buildSettingNumJobs               :: Int,        buildSettingKeepGoing             :: Bool,        buildSettingOfflineMode           :: Bool,@@ -456,5 +456,6 @@        buildSettingCacheDir              :: FilePath,        buildSettingHttpTransport         :: Maybe String,        buildSettingIgnoreExpiry          :: Bool,-       buildSettingProgPathExtra         :: [FilePath]+       buildSettingProgPathExtra         :: [FilePath],+       buildSettingHaddockOpen           :: Bool      }
src/Distribution/Client/ProjectFlags.hs view
@@ -4,13 +4,16 @@     ProjectFlags(..),     defaultProjectFlags,     projectFlagsOptions,+    removeIgnoreProjectOption, ) where  import Distribution.Client.Compat.Prelude import Prelude ()  import Distribution.ReadE          (succeedReadE)-import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg)+import Distribution.Simple.Command+    ( MkOptDescr, OptionField(optionName), ShowOrParseArgs (..), boolOpt', option+    , reqArg ) import Distribution.Simple.Setup   (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)  data ProjectFlags = ProjectFlags@@ -44,9 +47,18 @@         (reqArg "FILE" (succeedReadE Flag) flagToList)     , option ['z'] ["ignore-project"]         "Ignore local project configuration"-        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v })+        -- Flag True: --ignore-project is given and --project-file is not given+        -- Flag False: --ignore-project and --project-file is given+        -- NoFlag: neither --ignore-project or --project-file is given+        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = if v == NoFlag then NoFlag else toFlag ((flagProjectFileName flags) == NoFlag && v == Flag True) })         (yesNoOpt showOrParseArgs)     ]++-- | As almost all commands use 'ProjectFlags' but not all can honour+-- "ignore-project" flag, provide this utility to remove the flag+-- parsing from the help message.+removeIgnoreProjectOption :: [OptionField a] -> [OptionField a]+removeIgnoreProjectOption = filter (\o -> optionName o /= "ignore-project")  instance Monoid ProjectFlags where     mempty = gmempty
src/Distribution/Client/ProjectOrchestration.hs view
@@ -58,6 +58,8 @@     reportTargetSelectorProblems,     resolveTargets,     TargetsMap,+    allTargetSelectors,+    uniqueTargetSelectors,     TargetSelector(..),     TargetImplicitCwd(..),     PackageId,@@ -111,7 +113,6 @@ import           Distribution.Client.ProjectPlanning.Types import           Distribution.Client.ProjectBuilding import           Distribution.Client.ProjectPlanOutput-import           Distribution.Client.RebuildMonad ( runRebuild )  import           Distribution.Client.TargetProblem                    ( TargetProblem (..) )@@ -119,7 +120,10 @@                    ( GenericReadyPackage(..), UnresolvedSourcePackage                    , PackageSpecifier(..)                    , SourcePackageDb(..)-                   , WriteGhcEnvironmentFilesPolicy(..) )+                   , WriteGhcEnvironmentFilesPolicy(..)+                   , PackageLocation(..)+                   , DocsResult(..)+                   , TestsResult(..) ) import           Distribution.Solver.Types.PackageIndex                    ( lookupPackageName ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -128,12 +132,21 @@                    , ComponentKind(..), componentKind                    , readTargetSelectors, reportTargetSelectorProblems ) import           Distribution.Client.DistDirLayout++import           Distribution.Client.BuildReports.Anonymous (cabalInstallID)+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports+import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeLocal )+ import           Distribution.Client.Config (getCabalDir)+import           Distribution.Client.HttpUtils import           Distribution.Client.Setup hiding (packageName) import           Distribution.Compiler                    ( CompilerFlavor(GHC) ) import           Distribution.Types.ComponentName                    ( componentNameString )+import           Distribution.Types.InstalledPackageInfo+                   ( InstalledPackageInfo ) import           Distribution.Types.UnqualComponentName                    ( UnqualComponentName, packageNameToUnqualComponentName ) @@ -151,18 +164,22 @@ 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 ) import           Distribution.Simple.Compiler-                   ( compilerCompatVersion, showCompilerId+                   ( compilerCompatVersion, showCompilerId, compilerId, compilerInfo                    , OptimisationLevel(..))+import           Distribution.Utils.NubList+                   ( fromNubList )+import           Distribution.System+                   ( Platform(Platform) )  import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Map as Map-import           Control.Exception (assert)+import           Control.Exception ( assert ) #ifdef MIN_VERSION_unix import           System.Posix.Signals (sigKILL, sigSEGV) #endif@@ -195,7 +212,7 @@     establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand   where     mprojectFile   = Setup.flagToMaybe projectConfigProjectFile-    ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig+    ProjectConfigShared { projectConfigProjectFile} = projectConfigShared cliConfig  -- | Like 'establishProjectBaseContext' but doesn't search for project root. establishProjectBaseContextWithRoot@@ -209,8 +226,13 @@      let distDirLayout  = defaultDistDirLayout projectRoot mdistDirectory +    httpTransport <- configureTransport verbosity+                     (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)+                     (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)+     (projectConfig, localPackages) <-       rebuildProjectConfig verbosity+                           httpTransport                            distDirLayout                            cliConfig @@ -401,7 +423,7 @@   = return ()  runProjectPostBuildPhase verbosity-                         ProjectBaseContext {..} ProjectBuildContext {..}+                         ProjectBaseContext {..} bc@ProjectBuildContext {..}                          buildOutcomes = do     -- Update other build artefacts     -- TODO: currently none, but could include:@@ -422,6 +444,7 @@           projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared           $ projectConfig +        shouldWriteGhcEnvironment :: Bool         shouldWriteGhcEnvironment =           case fromFlagOrDefault NeverWriteGhcEnvironmentFiles                writeGhcEnvFilesPolicy@@ -439,6 +462,9 @@                                      elaboratedShared                                      postBuildStatus +    -- Write the build reports+    writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes+     -- Finally if there were any build failures then report them and throw     -- an exception to terminate the program     dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes@@ -473,8 +499,16 @@ -- 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 +563,7 @@                  -> TargetsMap     mkTargetsMap targets =         Map.map nubComponentTargets-      $ Map.fromListWith (++)+      $ Map.fromListWith (<>)           [ (uid, [(ct, ts)])           | (ts, cts) <- targets           , (uid, ct) <- cts ]@@ -659,37 +693,50 @@ availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes availableTargetIndexes installPlan = AvailableTargetIndexes{..}   where+    availableTargetsByPackageIdAndComponentName ::+      Map (PackageId, ComponentName)+          [AvailableTarget (UnitId, ComponentName)]     availableTargetsByPackageIdAndComponentName =       availableTargets installPlan +    availableTargetsByPackageId ::+      Map PackageId [AvailableTarget (UnitId, ComponentName)]     availableTargetsByPackageId =                   Map.mapKeysWith                     (++) (\(pkgid, _cname) -> pkgid)                     availableTargetsByPackageIdAndComponentName       `Map.union` availableTargetsEmptyPackages +    availableTargetsByPackageName ::+      Map PackageName [AvailableTarget (UnitId, ComponentName)]     availableTargetsByPackageName =       Map.mapKeysWith         (++) packageName         availableTargetsByPackageId +    availableTargetsByPackageNameAndComponentName ::+      Map (PackageName, ComponentName)+          [AvailableTarget (UnitId, ComponentName)]     availableTargetsByPackageNameAndComponentName =       Map.mapKeysWith         (++) (\(pkgid, cname) -> (packageName pkgid, cname))         availableTargetsByPackageIdAndComponentName +    availableTargetsByPackageNameAndUnqualComponentName ::+      Map (PackageName, UnqualComponentName)+          [AvailableTarget (UnitId, ComponentName)]     availableTargetsByPackageNameAndUnqualComponentName =       Map.mapKeysWith         (++) (\(pkgid, cname) -> let pname  = packageName pkgid                                      cname' = unqualComponentName pname cname                                   in (pname, cname'))         availableTargetsByPackageIdAndComponentName-     where-       unqualComponentName ::-         PackageName -> ComponentName -> UnqualComponentName-       unqualComponentName pkgname =-           fromMaybe (packageNameToUnqualComponentName pkgname)-         . componentNameString+      where+        unqualComponentName ::+          PackageName -> ComponentName -> UnqualComponentName+        unqualComponentName pkgname =+            fromMaybe (packageNameToUnqualComponentName pkgname)+          . componentNameString      -- Add in all the empty packages. These do not appear in the     -- availableTargetsByComponent map, since that only contains@@ -722,26 +769,24 @@         , p (componentKind cname) ]  selectBuildableTargets :: [AvailableTarget k] -> [k]-selectBuildableTargets ts =-    [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]+selectBuildableTargets = selectBuildableTargetsWith (const True) +zipBuildableTargetsWith :: (TargetRequested -> Bool)+                        -> [AvailableTarget k] -> [(k, AvailableTarget k)]+zipBuildableTargetsWith p ts =+    [ (k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req ]+ selectBuildableTargetsWith :: (TargetRequested -> Bool)                           -> [AvailableTarget k] -> [k]-selectBuildableTargetsWith p ts =-    [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]+selectBuildableTargetsWith p = map fst . zipBuildableTargetsWith p  selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])-selectBuildableTargets' ts =-    (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]-        [ forgetTargetDetail t-        | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ]+selectBuildableTargets' = selectBuildableTargetsWith' (const True)  selectBuildableTargetsWith' :: (TargetRequested -> Bool)                            -> [AvailableTarget k] -> ([k], [AvailableTarget ()])-selectBuildableTargetsWith' p ts =-    (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]-        [ forgetTargetDetail t-        | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ]+selectBuildableTargetsWith' p =+  (fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p   forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()@@ -865,6 +910,7 @@         in "(" ++ showBuildStatus buildStatus ++ ")"       ] +    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String     showComp elab comp =         maybe "custom" prettyShow (compComponentName comp) ++         if Map.null (elabInstantiatedWith elab)@@ -879,6 +925,7 @@     nonDefaultFlags elab =       elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab +    showTargets :: ElaboratedConfiguredPackage -> String     showTargets elab       | null (elabBuildTargets elab) = ""       | otherwise@@ -887,6 +934,7 @@                             | t <- elabBuildTargets elab ]         ++ ")" +    showConfigureFlags :: ElaboratedConfiguredPackage -> String     showConfigureFlags elab =         let fullConfigureFlags               = setupHsConfigureFlags@@ -920,6 +968,7 @@             (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))             partialConfigureFlags +    showBuildStatus :: BuildStatus -> String     showBuildStatus status = case status of       BuildStatusPreExisting -> "existing package"       BuildStatusInstalled   -> "already installed"@@ -937,6 +986,7 @@           BuildReasonEphemeralTargets -> "ephemeral targets"       BuildStatusUpToDate {} -> "up to date" -- doesn't happen +    showMonitorChangedReason :: MonitorChangedReason a -> String     showMonitorChangedReason (MonitoredFileChanged file) =       "file " ++ file ++ " changed"     showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"@@ -944,6 +994,7 @@     showMonitorChangedReason  MonitorCorruptCache        =       "cannot read state cache" +    showBuildProfile :: String     showBuildProfile = "Build profile: " ++ unwords [       "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,       "-O" ++  (case packageConfigOptimization of@@ -953,6 +1004,59 @@                 Setup.NoFlag                   -> "1")]       ++ "\n" ++writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()+writeBuildReports settings buildContext plan buildOutcomes = do+  let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext+      comp = pkgConfigCompiler . elaboratedShared $ buildContext+      getRepo (RepoTarballPackage r _ _) = Just r+      getRepo _ = Nothing+      fromPlanPackage (InstallPlan.Configured pkg) (Just result) =+            let installOutcome = case result of+                   Left bf -> case buildFailureReason bf of+                      DependentFailed p -> BuildReports.DependencyFailed p+                      DownloadFailed _  -> BuildReports.DownloadFailed+                      UnpackFailed _ -> BuildReports.UnpackFailed+                      ConfigureFailed _ -> BuildReports.ConfigureFailed+                      BuildFailed _ -> BuildReports.BuildFailed+                      TestsFailed _ -> BuildReports.TestsFailed+                      InstallFailed _ -> BuildReports.InstallFailed++                      ReplFailed _ -> BuildReports.InstallOk+                      HaddocksFailed _ -> BuildReports.InstallOk+                      BenchFailed _ -> BuildReports.InstallOk++                   Right _br -> BuildReports.InstallOk++                docsOutcome = case result of+                   Left bf -> case buildFailureReason bf of+                      HaddocksFailed _ -> BuildReports.Failed+                      _ -> BuildReports.NotTried+                   Right br -> case buildResultDocs br of+                      DocsNotTried -> BuildReports.NotTried+                      DocsFailed -> BuildReports.Failed+                      DocsOk -> BuildReports.Ok++                testsOutcome = case result of+                   Left bf -> case buildFailureReason bf of+                      TestsFailed _ -> BuildReports.Failed+                      _ -> BuildReports.NotTried+                   Right br -> case buildResultTests br of+                      TestsNotTried -> BuildReports.NotTried+                      TestsOk -> BuildReports.Ok++            in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?+      fromPlanPackage _ _ = Nothing+      buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan+++  BuildReports.storeLocal (compilerInfo comp)+                          (buildSettingSummaryFile settings)+                          buildReports+                          plat+  -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1+  -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.+ -- | If there are build failures then report them and throw an exception. -- dieOnBuildFailures :: Verbosity -> CurrentCommand@@ -991,9 +1095,11 @@          | let mentionDepOf = verbosity <= normal          , (pkg, failureClassification) <- failuresClassification ]   where+    failures :: [(UnitId, BuildFailure)]     failures =  [ (pkgid, failure)                 | (pkgid, Left failure) <- Map.toList buildOutcomes ] +    failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]     failuresClassification =       [ (pkg, classifyBuildFailure failure)       | (pkgid, failure) <- failures@@ -1004,6 +1110,7 @@            maybeToList (InstallPlan.lookup plan pkgid)       ] +    dieIfNotHaddockFailure :: Verbosity -> String -> IO ()     dieIfNotHaddockFailure       | currentCommand == HaddockCommand            = die'       | all isHaddockFailure failuresClassification = warn@@ -1040,6 +1147,7 @@     --    detail itself (e.g. ghc reporting errors on stdout)     --  - then we do not report additional error detail or context.     --+    isSimpleCase :: Bool     isSimpleCase       | [(pkgid, failure)] <- failures       , [pkg]              <- rootpkgs@@ -1053,6 +1161,7 @@     -- NB: if the Setup script segfaulted or was interrupted,     -- we should give more detailed information.  So only     -- assume that exit code 1 is "pedestrian failure."+    isFailureSelfExplanatory :: BuildFailureReason -> Bool     isFailureSelfExplanatory (BuildFailed e)       | Just (ExitFailure 1) <- fromException e = True @@ -1061,11 +1170,15 @@      isFailureSelfExplanatory _                  = False +    rootpkgs :: [ElaboratedConfiguredPackage]     rootpkgs =       [ pkg       | InstallPlan.Configured pkg <- InstallPlan.toList plan       , hasNoDependents pkg ] +    ultimateDeps+      :: UnitId+      -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]     ultimateDeps pkgid =         filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)                (InstallPlan.reverseDependencyClosure plan [pkgid])@@ -1073,11 +1186,13 @@     hasNoDependents :: HasUnitId pkg => pkg -> Bool     hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId +    renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String     renderFailureDetail mentionDepOf pkg reason =         renderFailureSummary mentionDepOf pkg reason ++ "."      ++ renderFailureExtraDetail reason      ++ maybe "" showException (buildFailureException reason) +    renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String     renderFailureSummary mentionDepOf pkg reason =         case reason of           DownloadFailed  _ -> "Failed to download " ++ pkgstr@@ -1099,6 +1214,7 @@                    then renderDependencyOf (installedUnitId pkg)                    else "" +    renderFailureExtraDetail :: BuildFailureReason -> String     renderFailureExtraDetail (ConfigureFailed _) =       " The failure occurred during the configure step."     renderFailureExtraDetail (InstallFailed   _) =@@ -1106,6 +1222,7 @@     renderFailureExtraDetail _                   =       "" +    renderDependencyOf :: UnitId -> String     renderDependencyOf pkgid =       case ultimateDeps pkgid of         []         -> ""@@ -1167,6 +1284,7 @@              ++ show e #endif +    buildFailureException :: BuildFailureReason -> Maybe SomeException     buildFailureException reason =       case reason of         DownloadFailed  e -> Just e@@ -1193,21 +1311,16 @@ establishDummyProjectBaseContext   :: Verbosity   -> ProjectConfig+     -- ^ Project configuration including the global config if needed   -> DistDirLayout      -- ^ Where to put the dist directory   -> [PackageSpecifier UnresolvedSourcePackage]      -- ^ The packages to be included in the project   -> CurrentCommand   -> IO ProjectBaseContext-establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do+establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do     cabalDir <- getCabalDir -    globalConfig <- runRebuild ""-                  $ readGlobalConfig verbosity-                  $ projectConfigConfigFile-                  $ projectConfigShared cliConfig-    let projectConfig = globalConfig <> cliConfig-     let ProjectConfigBuildOnly {           projectConfigLogsDir         } = projectConfigBuildOnly projectConfig@@ -1220,6 +1333,7 @@         mstoreDir = flagToMaybe projectConfigStoreDir         cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir +        buildSettings :: BuildTimeSettings         buildSettings = resolveBuildTimeSettings                           verbosity cabalDirLayout                           projectConfig
src/Distribution/Client/ProjectPlanOutput.hs view
@@ -23,7 +23,7 @@ import           Distribution.Client.Types.ConfiguredId (confInstId) import           Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import           Distribution.Client.HashValue (showHashValue, hashValue)-import           Distribution.Client.Utils (cabalInstallVersion)+import           Distribution.Client.Version (cabalInstallVersion)  import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J@@ -45,11 +45,13 @@                    , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile                    , writeGhcEnvironmentFile ) import           Distribution.Simple.BuildPaths-                   ( dllExtension, exeExtension )+                   ( dllExtension, exeExtension, buildInfoPref ) import qualified Distribution.Compat.Graph as Graph import           Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary import           Distribution.Simple.Utils+import           Distribution.Types.Version+                   ( mkVersion ) import           Distribution.Verbosity  import Prelude ()@@ -100,6 +102,7 @@              , "install-plan"      J..= installPlanToJ elaboratedInstallPlan              ]   where+    plat :: Platform     plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig      installPlanToJ :: ElaboratedInstallPlan -> [J.Value]@@ -150,7 +153,7 @@         | Just hash <- [elabPkgSourceHash elab] ] ++         (case elabBuildStyle elab of             BuildInplaceOnly ->-                ["dist-dir"   J..= J.String dist_dir]+                ["dist-dir"   J..= J.String dist_dir] ++ [buildInfoFileLocation]             BuildAndInstall ->                 -- TODO: install dirs?                 []@@ -175,6 +178,20 @@             ] ++             bin_file (compSolverName comp)      where+      -- | Only add build-info file location if the Setup.hs CLI+      -- is recent enough to be able to generate build info files.+      -- Otherwise, write 'null'.+      --+      -- Consumers of `plan.json` can use the nullability of this file location+      -- to indicate that the given component uses `build-type: Custom`+      -- with an old lib:Cabal version.+      buildInfoFileLocation :: J.Pair+      buildInfoFileLocation+        | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0]+        = "build-info" J..= J.Null+        | otherwise+        = "build-info" J..= J.String (buildInfoPref dist_dir)+       packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value       packageLocationToJ pkgloc =         case pkgloc of@@ -225,9 +242,11 @@           , "subdir"   J..= fmap J.String srpSubdir           ] +      dist_dir :: FilePath       dist_dir = distBuildDirectory distDirLayout                     (elabDistDirParams elaboratedSharedConfig elab) +      bin_file :: ComponentDeps.Component -> [J.Pair]       bin_file c = case c of         ComponentDeps.ComponentExe s   -> bin_file' s         ComponentDeps.ComponentTest s  -> bin_file' s@@ -241,6 +260,7 @@                then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat                else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat +      flib_file' :: (Pretty a, Show a) => a -> [J.Pair]       flib_file' s =         ["bin-file" J..= J.String bin]        where@@ -259,7 +279,6 @@     jdisplay :: Pretty a => a -> J.Value     jdisplay = J.String . prettyShow - ----------------------------------------------------------------------------- -- Project status --@@ -580,6 +599,8 @@                 InstallPlan.Configured srcpkg -> elabLibDeps srcpkg                 InstallPlan.Installed  srcpkg -> elabLibDeps srcpkg         ]++    elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]     elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies      -- Was a build was attempted for this package?@@ -599,11 +620,13 @@     buildAttempted _ (Left BuildFailure {}) = True     buildAttempted _ (Right _)              = True +    lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool     lookupBuildStatusRequiresBuild def ipkgid =       case Map.lookup ipkgid pkgBuildStatus of         Nothing          -> def -- Not in the plan subset we did the dry-run on         Just buildStatus -> buildStatusRequiresBuild buildStatus +    packagesBuildLocal :: Set UnitId     packagesBuildLocal =       selectPlanPackageIdSet $ \pkg ->         case pkg of@@ -611,6 +634,7 @@           InstallPlan.Installed   _     -> False           InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg +    packagesBuildInplace :: Set UnitId     packagesBuildInplace =       selectPlanPackageIdSet $ \pkg ->         case pkg of@@ -618,7 +642,7 @@           InstallPlan.Installed   _     -> False           InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg                                         == BuildInplaceOnly-+    packagesAlreadyInStore :: Set UnitId     packagesAlreadyInStore =       selectPlanPackageIdSet $ \pkg ->         case pkg of@@ -626,6 +650,10 @@           InstallPlan.Installed   _ -> True           InstallPlan.Configured  _ -> False +    selectPlanPackageIdSet+      :: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage+          -> Bool)+      -> Set UnitId     selectPlanPackageIdSet p = Map.keysSet                              . Map.filter p                              $ InstallPlan.toMap plan@@ -902,6 +930,7 @@       ([], pkgs) -> checkSamePackageDBs pkgs       (pkgs, _)  -> checkSamePackageDBs pkgs   where+    checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack     checkSamePackageDBs pkgs =       case ordNub (map elabBuildPackageDBStack pkgs) of         [packageDbs] -> packageDbs@@ -914,10 +943,13 @@         -- this feature, e.g. write out multiple env files, one for each         -- compiler / project profile. +    inplacePackages :: [ElaboratedConfiguredPackage]     inplacePackages =       [ srcpkg       | srcpkg <- sourcePackages       , elabBuildStyle srcpkg == BuildInplaceOnly ]++    sourcePackages :: [ElaboratedConfiguredPackage]     sourcePackages =       [ srcpkg       | pkg <- InstallPlan.toList elaboratedInstallPlan
src/Distribution/Client/ProjectPlanning.hs view
@@ -40,6 +40,7 @@     -- * Utils required for building     pkgHasEphemeralBuildTargets,     elabBuildTargetWholeComponents,+    configureCompiler,      -- * Setup.hs CLI flags for building     setupHsScriptOptions,@@ -71,11 +72,13 @@ import Distribution.Client.Compat.Prelude  import           Distribution.Client.HashValue+import           Distribution.Client.HttpUtils import           Distribution.Client.ProjectPlanning.Types as Ty import           Distribution.Client.PackageHash import           Distribution.Client.RebuildMonad import           Distribution.Client.Store import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectConfig.Legacy import           Distribution.Client.ProjectPlanOutput  import           Distribution.Client.Types@@ -84,7 +87,7 @@ import           Distribution.Client.Dependency import           Distribution.Client.Dependency.Types import qualified Distribution.Client.IndexUtils as IndexUtils-import           Distribution.Client.Init (incVersion)+import           Distribution.Client.Utils (incVersion) import           Distribution.Client.Targets (userToPackageConstraint) import           Distribution.Client.DistDirLayout import           Distribution.Client.SetupWrapper@@ -97,6 +100,9 @@ import           Distribution.Utils.LogProgress import           Distribution.Utils.MapAccum +import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeLocal, fromPlanningFailure )+ import qualified Distribution.Solver.Types.ComponentDeps as CD import           Distribution.Solver.Types.ComponentDeps (ComponentDeps) import           Distribution.Solver.Types.ConstraintSource@@ -115,6 +121,8 @@ import           Distribution.Package import           Distribution.Types.AnnotatedId import           Distribution.Types.ComponentName+import           Distribution.Types.DumpBuildInfo+                   ( DumpBuildInfo (..) ) import           Distribution.Types.LibraryName import           Distribution.Types.GivenComponent   (GivenComponent(..))@@ -164,7 +172,7 @@ 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 @@ -295,11 +303,13 @@ -- packages within the project. -- rebuildProjectConfig :: Verbosity+                     -> HttpTransport                      -> DistDirLayout                      -> ProjectConfig                      -> IO ( ProjectConfig                            , [PackageSpecifier UnresolvedSourcePackage] ) rebuildProjectConfig verbosity+                     httpTransport                      distDirLayout@DistDirLayout {                        distProjectRootDirectory,                        distDirectory,@@ -317,11 +327,15 @@       runRebuild distProjectRootDirectory       $ rerunIfChanged verbosity                        fileMonitorProjectConfig-                       fileMonitorProjectConfigKey+                       fileMonitorProjectConfigKey -- todo check deps too?       $ do           liftIO $ info verbosity "Project settings changed, reconfiguring..."-          projectConfig <- phaseReadProjectConfig-          localPackages <- phaseReadLocalPackages projectConfig+          liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory+          projectConfigSkeleton <- phaseReadProjectConfig+          -- have to create the cache directory before configuring the compiler+          (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig)+          let projectConfig = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectConfigSkeleton+          localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)           return (projectConfig, localPackages)      info verbosity@@ -338,17 +352,22 @@     ProjectConfigShared { projectConfigConfigFile } =       projectConfigShared cliConfig +    ProjectConfigShared { projectConfigIgnoreProject } =+      projectConfigShared cliConfig++    fileMonitorProjectConfig ::+      FileMonitor+        (FilePath, FilePath)+        (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])     fileMonitorProjectConfig =-      newFileMonitor (distProjectCacheFile "config") :: FileMonitor-          (FilePath, FilePath)-          (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])+      newFileMonitor (distProjectCacheFile "config")      -- Read the cabal.project (or implicit config) and combine it with     -- arguments from the command line     ---    phaseReadProjectConfig :: Rebuild ProjectConfig+    phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton     phaseReadProjectConfig = do-      readProjectConfig verbosity projectConfigConfigFile distDirLayout+      readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout      -- Look for all the cabal packages in the project     -- some of which may be local src dirs, tarballs etc@@ -359,8 +378,8 @@                                projectConfigShared,                                projectConfigBuildOnly                              } = do-      pkgLocations <- findProjectPackages distDirLayout projectConfig +      pkgLocations <- findProjectPackages distDirLayout projectConfig       -- Create folder only if findProjectPackages did not throw a       -- BadPackageLocations exception.       liftIO $ do@@ -373,6 +392,60 @@                                  pkgLocations  +configureCompiler :: Verbosity ->+                     DistDirLayout ->+                     ProjectConfig ->+                     Rebuild (Compiler, Platform, ProgramDb)+configureCompiler verbosity+                  DistDirLayout {+                     distProjectCacheFile+                   }+                  ProjectConfig {+                             projectConfigShared = ProjectConfigShared {+                               projectConfigHcFlavor,+                               projectConfigHcPath,+                               projectConfigHcPkg+                             },+                             projectConfigLocalPackages = PackageConfig {+                               packageConfigProgramPaths,+                               packageConfigProgramPathExtra+                             }+                           } = do+        let fileMonitorCompiler       = newFileMonitor . distProjectCacheFile $ "compiler"++        progsearchpath <- liftIO $ getSystemSearchPath+        rerunIfChanged verbosity fileMonitorCompiler+                       (hcFlavor, hcPath, hcPkg, progsearchpath,+                        packageConfigProgramPaths,+                        packageConfigProgramPathExtra) $ do++          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."+          result@(_, _, progdb') <- liftIO $+            Cabal.configCompilerEx+              hcFlavor hcPath hcPkg+              progdb verbosity++        -- Note that we added the user-supplied program locations and args+        -- for /all/ programs, not just those for the compiler prog and+        -- compiler-related utils. In principle we don't know which programs+        -- the compiler will configure (and it does vary between compilers).+        -- We do know however that the compiler will only configure the+        -- programs it cares about, and those are the ones we monitor here.+          monitorFiles (programsMonitorFiles progdb')++          return result+      where+        hcFlavor = flagToMaybe projectConfigHcFlavor+        hcPath   = flagToMaybe projectConfigHcPath+        hcPkg    = flagToMaybe projectConfigHcPkg+        progdb   =+            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))+          . modifyProgramSearchPath+              (++ [ ProgramSearchPathDir dir+                  | dir <- fromNubList packageConfigProgramPathExtra ])+          $ defaultProgramDb++ -- | Return an up-to-date elaborated install plan. -- -- Two variants of the install plan are returned: with and without packages@@ -444,7 +517,6 @@       return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)    where-    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"     fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"     fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"     fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"@@ -461,52 +533,7 @@     --     phaseConfigureCompiler :: ProjectConfig                            -> Rebuild (Compiler, Platform, ProgramDb)-    phaseConfigureCompiler ProjectConfig {-                             projectConfigShared = ProjectConfigShared {-                               projectConfigHcFlavor,-                               projectConfigHcPath,-                               projectConfigHcPkg-                             },-                             projectConfigLocalPackages = PackageConfig {-                               packageConfigProgramPaths,-                               packageConfigProgramArgs,-                               packageConfigProgramPathExtra-                             }-                           } = do-        progsearchpath <- liftIO $ getSystemSearchPath-        rerunIfChanged verbosity fileMonitorCompiler-                       (hcFlavor, hcPath, hcPkg, progsearchpath,-                        packageConfigProgramPaths,-                        packageConfigProgramArgs,-                        packageConfigProgramPathExtra) $ do--          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."-          result@(_, _, progdb') <- liftIO $-            Cabal.configCompilerEx-              hcFlavor hcPath hcPkg-              progdb verbosity--        -- Note that we added the user-supplied program locations and args-        -- for /all/ programs, not just those for the compiler prog and-        -- compiler-related utils. In principle we don't know which programs-        -- the compiler will configure (and it does vary between compilers).-        -- We do know however that the compiler will only configure the-        -- programs it cares about, and those are the ones we monitor here.-          monitorFiles (programsMonitorFiles progdb')--          return result-      where-        hcFlavor = flagToMaybe projectConfigHcFlavor-        hcPath   = flagToMaybe projectConfigHcPath-        hcPkg    = flagToMaybe projectConfigHcPkg-        progdb   =-            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))-          . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))-          . modifyProgramSearchPath-              (++ [ ProgramSearchPathDir dir-                  | dir <- fromNubList packageConfigProgramPathExtra ])-          $ defaultProgramDb-+    phaseConfigureCompiler = configureCompiler verbosity distDirLayout      -- Configuring other programs.     --@@ -577,13 +604,19 @@                                    (compilerInfo compiler)              notice verbosity "Resolving dependencies..."-            plan <- foldProgress logMsg (die' verbosity) return $+            planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $               planPackages verbosity compiler platform solver solverSettings                            installedPkgIndex sourcePkgDb pkgConfigDB                            localPackages localPackagesEnabledStanzas-            return (plan, pkgConfigDB, tis, ar)+            case planOrError of+              Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages+                             die' verbosity msg+              Right plan -> return (plan, pkgConfigDB, tis, ar)       where-        corePackageDbs = [GlobalPackageDB]+        corePackageDbs :: [PackageDB]+        corePackageDbs = applyPackageDbFlags [GlobalPackageDB]+                                             (projectConfigPackageDBs projectConfigShared)+         withRepoCtx    = projectConfigWithSolverRepoContext verbosity                            projectConfigShared                            projectConfigBuildOnly@@ -594,7 +627,7 @@           Map.fromList             [ (pkgname, stanzas)             | pkg <- localPackages-              -- TODO: misnormer: we should separate+              -- TODO: misnomer: we should separate               -- builtin/global/inplace/local packages               -- and packages explicitly mentioned in the project               --@@ -716,6 +749,44 @@         compid = compilerId (pkgConfigCompiler elaboratedShared)  +-- | If a 'PackageSpecifier' refers to a single package, return Just that+-- package.+++reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO ()+reportPlanningFailure projectConfig comp platform pkgSpecifiers = when reportFailure $++    BuildReports.storeLocal (compilerInfo comp)+                            (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig)+                            buildReports platform++    -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely?+  where+    reportFailure = Cabal.fromFlag . projectConfigReportPlanningFailure . projectConfigBuildOnly $ projectConfig+    pkgids = mapMaybe theSpecifiedPackage pkgSpecifiers+    buildReports = BuildReports.fromPlanningFailure platform+                       (compilerId comp) pkgids+                       -- TODO we may want to get more flag assignments and merge them here?+                       (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig)++    theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId+    theSpecifiedPackage pkgSpec =+       case pkgSpec of+          NamedPackage name [PackagePropertyVersion version]+            -> PackageIdentifier name <$> trivialRange version+          NamedPackage _ _ -> Nothing+          SpecificSourcePackage pkg -> Just $ packageId pkg+    -- | If a range includes only a single version, return Just that version.+    trivialRange :: VersionRange -> Maybe Version+    trivialRange = foldVersionRange+        Nothing+        Just     -- "== v"+        (\_ -> Nothing)+        (\_ -> Nothing)+        (\_ _ -> Nothing)+        (\_ _ -> Nothing)++ programsMonitorFiles :: ProgramDb -> [MonitorFilePath] programsMonitorFiles progdb =     [ monitor@@ -935,6 +1006,12 @@     return $! hashesFromRepoMetadata            <> hashesFromTarballFiles +-- | Append the given package databases to an existing PackageDBStack.+-- A @Nothing@ entry will clear everything before it.+applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack+applyPackageDbFlags dbs' []            = dbs'+applyPackageDbFlags _    (Nothing:dbs) = applyPackageDbFlags []             dbs+applyPackageDbFlags dbs' (Just db:dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs  -- ------------------------------------------------------------ -- * Installation planning@@ -964,6 +1041,7 @@     --TODO: [nice to have] disable multiple instances restriction in     -- the solver, but then make sure we can cope with that in the     -- output.+    resolverParams :: DepResolverParams     resolverParams =          setMaxBackjumps solverSettingMaxBackjumps@@ -1024,13 +1102,14 @@             | (pc, src) <- solverSettingConstraints ]        . addPreferences-          -- enable stanza preference where the user did not specify+          -- enable stanza preference unilaterally, regardless if the user asked+          -- accordingly or expressed no preference, to help hint the solver           [ PackageStanzasPreference pkgname stanzas           | pkg <- localPackages           , let pkgname = pkgSpecifierTarget pkg                 stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable                 stanzas = [ stanza | stanza <- [minBound..maxBound]-                          , Map.lookup stanza stanzaM == Nothing ]+                          , Map.lookup stanza stanzaM /= Just False ]           , not (null stanzas)           ] @@ -1073,6 +1152,7 @@        $ stdResolverParams +    stdResolverParams :: DepResolverParams     stdResolverParams =       -- Note: we don't use the standardInstallPolicy here, since that uses       -- its own addDefaultSetupDependencies that is not appropriate for us.@@ -1101,6 +1181,7 @@     -- respective major Cabal version bundled with the respective GHC     -- release).     --+    -- GHC 9.2   needs  Cabal >= 3.6     -- GHC 9.0   needs  Cabal >= 3.4     -- GHC 8.10  needs  Cabal >= 3.2     -- GHC 8.8   needs  Cabal >= 3.0@@ -1116,6 +1197,8 @@     -- TODO: long-term, this compatibility matrix should be     --       stored as a field inside 'Distribution.Compiler.Compiler'     setupMinCabalVersionConstraint+      | isGHC, compVer >= mkVersion [9,4]  = mkVersion [3,8]+      | isGHC, compVer >= mkVersion [9,2]  = mkVersion [3,6]       | isGHC, compVer >= mkVersion [9,0]  = mkVersion [3,4]       | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]       | isGHC, compVer >= mkVersion [8,8]  = mkVersion [3,0]@@ -1282,9 +1365,10 @@         pkgConfigPlatform      = platform,         pkgConfigCompiler      = compiler,         pkgConfigCompilerProgs = compilerprogdb,-        pkgConfigReplOptions   = []+        pkgConfigReplOptions   = mempty       } +    preexistingInstantiatedPkgs :: Map UnitId FullUnitId     preexistingInstantiatedPkgs =         Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))       where@@ -1296,6 +1380,8 @@                                  (Map.fromList (IPI.instantiatedWith ipkg))))         f _ = Nothing +    elaboratedInstallPlan ::+      LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)     elaboratedInstallPlan =       flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->         case planpkg of@@ -1345,7 +1431,7 @@             -- invocation of the same `./configure` script.             -- See https://github.com/haskell/cabal/issues/4548             ---            -- Moreoever, at this point in time, only non-Custom setup scripts+            -- Moreover, at this point in time, only non-Custom setup scripts             -- are supported.  Implementing per-component builds with             -- Custom would require us to create a new 'ElabSetup'             -- type, and teach all of the code paths how to handle it.@@ -1671,10 +1757,6 @@                 elaboratedSharedConfig                 elab)  -- recursive use of elab -          | otherwise-          = error $ "elaborateInstallPlan: non-inplace package "-                 ++ " is missing a source hash: " ++ prettyShow pkgid-         -- Need to filter out internal dependencies, because they don't         -- correspond to anything real anymore.         isExt confid = confSrcId confid /= pkgid@@ -1759,7 +1841,7 @@             -- 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@@ -1789,6 +1871,7 @@         elabLocalToProject  = isLocalToProject pkg         elabBuildStyle      = if shouldBuildInplaceOnly pkg                                 then BuildInplaceOnly else BuildAndInstall+        elabPackageDbs             = projectConfigPackageDBs sharedPackageConfig         elabBuildPackageDBStack    = buildAndRegisterDbs         elabRegisterPackageDBStack = buildAndRegisterDbs @@ -1804,7 +1887,7 @@          buildAndRegisterDbs           | shouldBuildInplaceOnly pkg = inplacePackageDbs-          | otherwise                  = storePackageDbs+          | otherwise                  = corePackageDbs          elabPkgDescriptionOverride = descOverride @@ -1830,6 +1913,7 @@         elabStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs         elabStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes         elabDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo+        elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo          -- Combine the configured compiler prog settings with the user-supplied         -- config. For the compiler progs any user-supplied config was taken@@ -1850,6 +1934,7 @@         elabProgramPathExtra    = perPkgOptionNubList pkgid packageConfigProgramPathExtra         elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs         elabExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs+        elabExtraLibDirsStatic  = perPkgOptionList pkgid packageConfigExtraLibDirsStatic         elabExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs         elabExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs         elabProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix@@ -1915,10 +2000,11 @@                = mempty         perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) -    inplacePackageDbs = storePackageDbs+    inplacePackageDbs = corePackageDbs                      ++ [ distPackageDB (compilerId compiler) ] -    storePackageDbs   = storePackageDBStack (compilerId compiler)+    corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId compiler))+                                         (projectConfigPackageDBs sharedPackageConfig)      -- For this local build policy, every package that lives in a local source     -- dir (as opposed to a tarball), or depends on such a package, will be@@ -2578,7 +2664,7 @@ -- 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)@@ -2589,11 +2675,17 @@     -- 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@@ -2670,7 +2762,7 @@ -- | This is a temporary data type, where we temporarily -- override the graph dependencies of an 'ElaboratedPackage', -- so we can take a closure over them.  We'll throw out the--- overriden dependencies when we're done so it's strictly temporary.+-- overridden dependencies when we're done so it's strictly temporary. -- -- For 'ElaboratedComponent', this the cached unit IDs always -- coincide with the real thing.@@ -3117,7 +3209,7 @@ -- Note that adding default deps means these deps are actually /added/ to the -- packages that we get out of the solver in the 'SolverInstallPlan'. Making -- implicit setup deps explicit is a problem in the post-solver stages because--- we still need to distinguish the case of explicit and implict setup deps.+-- we still need to distinguish the case of explicit and implicit setup deps. -- See 'rememberImplicitSetupDeps'. -- -- Note in addition to adding default setup deps, we also use@@ -3417,12 +3509,11 @@           -- So for now, let's pass the rather harmless and idempotent           -- `-hide-all-packages` flag to all invocations (which has           -- the benefit that every GHC invocation starts with a-          -- conistently well-defined clean slate) until we find a+          -- consistently well-defined clean slate) until we find a           -- better way.                               = Map.toList $                                 Map.insertWith (++) "ghc" ["-hide-all-packages"]                                                elabProgramArgs-        | otherwise           = Map.toList elabProgramArgs     configProgramPathExtra    = toNubList elabProgramPathExtra     configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)     configHcPath              = mempty -- we use configProgramPaths instead@@ -3453,10 +3544,12 @@     configStripExes           = toFlag elabStripExes     configStripLibs           = toFlag elabStripLibs     configDebugInfo           = toFlag elabDebugInfo+    configDumpBuildInfo       = toFlag elabDumpBuildInfo      configConfigurationsFlags = elabFlagAssignment     configConfigureArgs       = elabConfigureScriptArgs     configExtraLibDirs        = elabExtraLibDirs+    configExtraLibDirsStatic  = elabExtraLibDirsStatic     configExtraFrameworkDirs  = elabExtraFrameworkDirs     configExtraIncludeDirs    = elabExtraIncludeDirs     configProgPrefix          = maybe mempty toFlag elabProgPrefix@@ -3808,6 +3901,7 @@       pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,       pkgHashProgPrefix          = elabProgPrefix,       pkgHashProgSuffix          = elabProgSuffix,+      pkgHashPackageDbs          = elabPackageDbs,        pkgHashDocumentation       = elabBuildHaddocks,       pkgHashHaddockHoogle       = elabHaddockHoogle,
src/Distribution/Client/ProjectPlanning/Types.hs view
@@ -95,7 +95,8 @@                    ( ComponentName(..), LibraryName(..) ) import qualified Distribution.Simple.InstallDirs as InstallDirs import           Distribution.Simple.InstallDirs (PathTemplate)-import           Distribution.Simple.Setup (HaddockTarget, TestShowDetails)+import           Distribution.Simple.Setup+                   ( HaddockTarget, TestShowDetails, DumpBuildInfo (..), ReplOptions ) import           Distribution.Version  import qualified Distribution.Solver.Types.ComponentDeps as CD@@ -147,7 +148,7 @@        -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are        -- used.        pkgConfigCompilerProgs :: ProgramDb,-       pkgConfigReplOptions :: [String]+       pkgConfigReplOptions :: ReplOptions      }   deriving (Show, Generic, Typeable)   --TODO: [code cleanup] no Eq instance@@ -233,6 +234,7 @@        -- warn if ALL local packages don't have any tests.)        elabStanzasRequested :: OptionalStanzaMap (Maybe Bool), +       elabPackageDbs             :: [Maybe PackageDB],        elabSetupPackageDBStack    :: PackageDBStack,        elabBuildPackageDBStack    :: PackageDBStack,        elabRegisterPackageDBStack :: PackageDBStack,@@ -261,12 +263,14 @@        elabStripLibs            :: Bool,        elabStripExes            :: Bool,        elabDebugInfo            :: DebugInfoLevel,+       elabDumpBuildInfo        :: DumpBuildInfo,         elabProgramPaths          :: Map String FilePath,        elabProgramArgs           :: Map String [String],        elabProgramPathExtra      :: [FilePath],        elabConfigureScriptArgs   :: [String],        elabExtraLibDirs          :: [FilePath],+       elabExtraLibDirsStatic    :: [FilePath],        elabExtraFrameworkDirs    :: [FilePath],        elabExtraIncludeDirs      :: [FilePath],        elabProgPrefix            :: Maybe PathTemplate,
src/Distribution/Client/RebuildMonad.hs view
@@ -79,7 +79,7 @@ newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)   deriving (Functor, Applicative, Monad, MonadIO) --- | Use this wihin the body action of 'rerunIfChanged' to declare that the+-- | Use this within the body action of 'rerunIfChanged' to declare that the -- action depends on the given files. This can be based on what the action -- actually did. It is these files that will be checked for changes next -- time 'rerunIfChanged' is called for that 'FileMonitor'.@@ -294,9 +294,10 @@     , ext <- nub extensions ]  -- | Like 'findFirstFile', but in the 'Rebuild' monad.-findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)+findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a) findFirstFileMonitored file = findFirst-  where findFirst []     = return Nothing+  where findFirst        :: [a] -> Rebuild (Maybe a)+        findFirst []     = return Nothing         findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)                               if exists                                 then return (Just x)
src/Distribution/Client/Reconfigure.hs view
@@ -119,14 +119,16 @@      else do -      let checks =+      let checks :: Check (ConfigFlags, ConfigExFlags)+          checks =             checkVerb             <> checkDist             <> checkOutdated             <> check       (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags -      let config' = updateInstallDirs (configUserInstall configFlags) config+      let config' :: SavedConfig+          config' = updateInstallDirs (configUserInstall configFlags) config        when frc $ configureAction flags extraArgs globalFlags       return config'@@ -135,22 +137,29 @@      -- Changing the verbosity does not require reconfiguration, but the new     -- verbosity should be used if reconfiguring.+    checkVerb :: Check (ConfigFlags, b)     checkVerb = Check $ \_ (configFlags, configExFlags) -> do-      let configFlags' = configFlags { configVerbosity = toFlag verbosity}+      let configFlags' :: ConfigFlags+          configFlags' = configFlags { configVerbosity = toFlag verbosity}       return (mempty, (configFlags', configExFlags))      -- Reconfiguration is required if @--build-dir@ changes.+    checkDist :: Check (ConfigFlags, b)     checkDist = Check $ \_ (configFlags, configExFlags) -> do       -- Always set the chosen @--build-dir@ before saving the flags,       -- or bad things could happen.       savedDist <- findSavedDistPref config (configDistPref configFlags)-      let distChanged = dist /= savedDist+      let distChanged :: Bool+          distChanged = dist /= savedDist       when distChanged $ info verbosity "build directory changed"-      let configFlags' = configFlags { configDistPref = toFlag dist }+      let configFlags' :: ConfigFlags+          configFlags' = configFlags { configDistPref = toFlag dist }       return (Any distChanged, (configFlags', configExFlags)) +    checkOutdated :: Check (ConfigFlags, b)     checkOutdated = Check $ \_ flags@(configFlags, _) -> do-      let buildConfig = localBuildInfoFile dist+      let buildConfig :: FilePath+          buildConfig = localBuildInfoFile dist        -- Has the package ever been configured? If not, reconfiguration is       -- required.@@ -172,7 +181,8 @@       outdated <- existsAndIsMoreRecentThan descrFile buildConfig       when outdated $ info verbosity (descrFile ++ " was changed") -      let failed =+      let failed :: Any+          failed =             Any outdated             <> Any userPackageEnvironmentFileModified             <> Any (not configured)
+ src/Distribution/Client/ScriptUtils.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Utilities to help commands with scripts+--+module Distribution.Client.ScriptUtils (+    getScriptCacheDirectoryRoot, getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,+    withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),+    updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',+    fakeProjectSourcePackage, lSrcpkgDescription+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (toList)++import Distribution.Compat.Lens+import qualified Distribution.Types.Lens as L++import Distribution.CabalSpecVersion+    ( CabalSpecVersion (..), cabalSpecLatest)+import Distribution.Client.ProjectOrchestration+import Distribution.Client.Config+    ( getCabalDir )+import Distribution.Client.DistDirLayout+    ( DistDirLayout(..) )+import Distribution.Client.HashValue+    ( hashValue, showHashValue )+import Distribution.Client.HttpUtils+         ( HttpTransport, configureTransport )+import Distribution.Client.NixStyleOptions+    ( NixStyleFlags (..) )+import Distribution.Client.ProjectConfig+    ( ProjectConfig(..), ProjectConfigShared(..)+    , reportParseResult, withProjectOrGlobalConfig+    , projectConfigHttpTransport )+import Distribution.Client.ProjectConfig.Legacy+    ( ProjectConfigSkeleton+    , parseProjectSkeleton, instantiateProjectConfigSkeleton )+import Distribution.Client.ProjectFlags+    ( flagIgnoreProject )+import Distribution.Client.RebuildMonad+    ( runRebuild )+import Distribution.Client.Setup+    ( ConfigFlags(..), GlobalFlags(..) )+import Distribution.Client.TargetSelector+    ( TargetSelectorProblem(..), TargetString(..) )+import Distribution.Client.Types+    ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )+import Distribution.FieldGrammar+    ( parseFieldGrammar, takeFields )+import Distribution.Fields+    ( ParseResult, parseFatalFailure, readFields )+import Distribution.PackageDescription+    ( ignoreConditions )+import Distribution.PackageDescription.FieldGrammar+    ( executableFieldGrammar )+import Distribution.PackageDescription.PrettyPrint+    ( showGenericPackageDescription )+import Distribution.Parsec+    ( Position(..) )+import Distribution.Simple.Flag+    ( fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.PackageDescription+    ( parseString )+import Distribution.Simple.Setup+    ( Flag(..) )+import Distribution.Simple.Compiler+    ( compilerInfo )+import Distribution.Simple.Utils+    ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )+import qualified Distribution.SPDX.License as SPDX+import Distribution.Solver.Types.SourcePackage as SP+    ( SourcePackage(..) )+import Distribution.System+    ( Platform(..) )+import Distribution.Types.BuildInfo+    ( BuildInfo(..) )+import Distribution.Types.CondTree+    ( CondTree(..) )+import Distribution.Types.Executable+    ( Executable(..) )+import Distribution.Types.GenericPackageDescription as GPD+    ( GenericPackageDescription(..), emptyGenericPackageDescription )+import Distribution.Types.PackageDescription+    ( PackageDescription(..), emptyPackageDescription )+import Distribution.Types.PackageName.Magic+    ( fakePackageCabalFileName, fakePackageId )+import Distribution.Utils.NubList+    ( fromNubList )+import Distribution.Client.ProjectPlanning+    ( configureCompiler )+import Distribution.Verbosity+    ( normal )+import Language.Haskell.Extension+    ( Language(..) )++import Control.Concurrent.MVar+    ( newEmptyMVar, putMVar, tryTakeMVar )+import Control.Exception+    ( bracket )+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Lazy ()+import qualified Data.Set as S+import System.Directory+    ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )+import System.FilePath+    ( (</>), takeFileName )+import qualified Text.Parsec as P++-- A note on multi-module script support #6787:+-- Multi-module scripts are not supported and support is non-trivial.+-- What you want to do is pass the absolute path to the script's directory in hs-source-dirs,+-- but hs-source-dirs only accepts relative paths. This leaves you with several options none+-- of which are particularly appealing.+-- 1) Loosen the requirement that hs-source-dirs take relative paths+-- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path+-- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the+--    repl to deal with the fact that the repl is relative to the working directory and not+--    the project root.++-- | Get the directory where script builds are cached.+--+-- @CABAL_DIR\/script-builds\/@+getScriptCacheDirectoryRoot :: IO FilePath+getScriptCacheDirectoryRoot = do+  cabalDir <- getCabalDir+  return $ cabalDir </> "script-builds"++-- | Get the hash of a script's absolute path)+--+-- Two hashes will be the same as long as the absolute paths+-- are the same.+getScriptHash :: FilePath -> IO String+getScriptHash script = showHashValue . hashValue . fromString <$> canonicalizePath script++-- | Get the directory for caching a script build.+--+-- The only identity of a script is it's absolute path, so append the+-- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory.+getScriptCacheDirectory :: FilePath -> IO FilePath+getScriptCacheDirectory script = (</>) <$> getScriptCacheDirectoryRoot <*> getScriptHash script++-- | Get the directory for caching a script build and ensure it exists.+--+-- The only identity of a script is it's absolute path, so append the+-- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory.+ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath+ensureScriptCacheDirectory verbosity script = do+  cacheDir <- getScriptCacheDirectory script+  createDirectoryIfMissingVerbose verbosity True cacheDir+  return cacheDir++-- | What your command should do when no targets are found.+data AcceptNoTargets+  = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject'+  | AcceptNoTargets -- ^ return a default 'TargetSelector'+  deriving (Eq, Show)++-- | Information about the context in which we found the 'TargetSelector's.+data TargetContext+  = ProjectContext -- ^ The target selectors are part of a project.+  | GlobalContext  -- ^ The target selectors are from the global context.+  | ScriptContext FilePath Executable+  -- ^ The target selectors refer to a script. Contains the path to the script and+  -- the executable metadata parsed from the script+  deriving (Eq, Show)++-- | Determine whether the targets represent regular targets or a script+-- and return the proper context and target selectors.+-- Die with an error message if selectors are valid as neither regular targets or as a script.+--+-- In the case that the context refers to a temporary directory,+-- delete it after the action finishes.+withContextAndSelectors+  :: AcceptNoTargets     -- ^ What your command should do when no targets are found.+  -> Maybe ComponentKind -- ^ A target filter+  -> NixStyleFlags a     -- ^ Command line flags+  -> [String]            -- ^ Target strings or a script and args.+  -> GlobalFlags         -- ^ Global flags.+  -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)+  -- ^ The body of your command action.+  -> IO b+withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags act+  = withTemporaryTempDirectory $ \mkTmpDir -> do+    (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir)++    (tc', ctx', sels) <- case targetStrings of+      -- Only script targets may contain spaces and or end with ':'.+      -- Trying to readTargetSelectors such a target leads to a parse error.+      [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do+          scriptOrError target [TargetSelectorNoScript $ TargetString1 target]+      _                                                   -> do+        -- In the case where a selector is both a valid target and script, assume it is a target,+        -- because you can disambiguate the script with "./script"+        readTargetSelectors (localPackages ctx) kind targetStrings >>= \case+          Left err@(TargetSelectorNoTargetsInProject:_)+            | [] <- targetStrings+            , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget)+            | (script:_) <- targetStrings  -> scriptOrError script err+          Left err@(TargetSelectorNoSuch t _:_)+            | TargetString1 script <- t    -> scriptOrError script err+          Left err@(TargetSelectorExpected t _ _:_)+            | TargetString1 script <- t    -> scriptOrError script err+          Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name.+            | [script] <- targetStrings    -> scriptOrError script err+          Left err                         -> reportTargetSelectorProblems verbosity err+          Right sels                       -> return (tc, ctx, sels)++    act tc' ctx' sels+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)+    defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing]++    with = do+      ctx <- establishProjectBaseContext verbosity cliConfig OtherCommand+      return (ProjectContext, ctx)+    without mkDir globalConfig = do+      distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkDir+      ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand+      return (GlobalContext, ctx)+    scriptOrError script err = do+      exists <- doesFileExist script+      if exists then do+        -- In the script case we always want a dummy context even when ignoreProject is False+        let mkCacheDir = ensureScriptCacheDirectory verbosity script+        (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir)++        let projectRoot = distProjectRootDirectory $ distDirLayout ctx+        writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script++        scriptContents <- BS.readFile script+        executable     <- readExecutableBlockFromScript verbosity scriptContents+++        httpTransport <- configureTransport verbosity+                     (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)+                     (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)++        projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents++        (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx)++        let projectCfg = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectCfgSkeleton :: ProjectConfig++        let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just+            ctx'        = ctx & lProjectConfig %~ (<> projectCfg)+        return (ScriptContext script executable', ctx', defaultTarget)+      else reportTargetSelectorProblems verbosity err++withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a+withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act+  where+    -- We return an (IO Filepath) instead of a FilePath for two reasons:+    -- 1) To give the consumer the discretion to not create the tmpDir,+    --    but still grantee that it's deleted if they do create it+    -- 2) Because the path returned by createTempDirectory is not predicable+    getMkTmp m = return $ do+      tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl."+      putMVar m tmpDir+      return tmpDir+    rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive)++-- | Add the 'SourcePackage' to the context and use it to write a .cabal file.+updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext+updateContextAndWriteProjectFile' ctx srcPkg = do+  let projectRoot      = distProjectRootDirectory $ distDirLayout ctx+      packageFile      = projectRoot </> fakePackageCabalFileName+      contents         = showGenericPackageDescription (srcpkgDescription srcPkg)+      writePackageFile = writeUTF8File packageFile contents+  -- TODO This is here to prevent reconfiguration of cached repl packages.+  -- It's worth investigating why it's needed in the first place.+  packageFileExists <- doesFileExist packageFile+  if packageFileExists then do+    cached <- force <$> readUTF8File packageFile+    when (cached /= contents)+      writePackageFile+  else writePackageFile+  return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg]))++-- | Add add the executable metadata to the context and write a .cabal file.+updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext+updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do+  let projectRoot = distProjectRootDirectory $ distDirLayout ctx++  absScript <- canonicalizePath scriptPath+  let+    -- Replace characters which aren't allowed in the executable component name with '_'+    -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled+    scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath)+    censor c | c `S.member` ccNamecore = c+             | otherwise               = '_'++    sourcePackage = fakeProjectSourcePackage projectRoot+      & lSrcpkgDescription . L.condExecutables+      .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])]+    executable = scriptExecutable+      & L.modulePath .~ absScript++  updateContextAndWriteProjectFile' ctx sourcePackage++parseScriptBlock :: BS.ByteString -> ParseResult Executable+parseScriptBlock str =+    case readFields str of+        Right fs -> do+            let (fields, _) = takeFields fs+            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")+        Left perr -> parseFatalFailure pos (show perr) where+            ppos = P.errorPos perr+            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)++readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable+readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"++-- | Extract the first encountered executable metadata block started and+-- terminated by the below tokens or die.+--+-- * @{- cabal:@+--+-- * @-}@+--+-- Return the metadata.+readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable+readExecutableBlockFromScript verbosity str = do+    str' <- case extractScriptBlock "cabal" str of+              Left e -> die' verbosity $ "Failed extracting script block: " ++ e+              Right x -> return x+    when (BS.all isSpace str') $ warn verbosity "Empty script block"+    readScriptBlock verbosity str'++-- | Extract the first encountered project metadata block started and+-- terminated by the below tokens.+--+-- * @{- project:@+--+-- * @-}@+--+-- Return the metadata.+readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton+readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do+    case extractScriptBlock "project" str of+        Left  _ -> return mempty+        Right x ->    reportParseResult verbosity "script" scriptName+                  =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x++-- | Extract the first encountered script metadata block started end+-- terminated by the tokens+--+-- * @{- <header>:@+--+-- * @-}@+--+-- appearing alone on lines (while tolerating trailing whitespace).+-- These tokens are not part of the 'Right' result.+--+-- In case of missing or unterminated blocks a 'Left'-error is+-- returned.+extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString+extractScriptBlock header str = goPre (BS.lines str)+  where+    isStartMarker = (== startMarker) . stripTrailSpace+    isEndMarker   = (== endMarker) . stripTrailSpace++    stripTrailSpace = fst . BS.spanEnd isSpace++    -- before start marker+    goPre ls = case dropWhile (not . isStartMarker) ls of+                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"+                 (_:ls') -> goBody [] ls'++    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"+    goBody acc (l:ls)+      | isEndMarker l = Right $! BS.unlines $ reverse acc+      | otherwise     = goBody (l:acc) ls++    startMarker, endMarker :: BS.ByteString+    startMarker = "{- " <> header <> ":"+    endMarker   = "-}"++-- | The base for making a 'SourcePackage' for a fake project.+-- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.+fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)+fakeProjectSourcePackage projectRoot = sourcePackage+  where+    sourcePackage = SourcePackage+      { srcpkgPackageId     = fakePackageId+      , srcpkgDescription   = genericPackageDescription+      , srcpkgSource        = LocalUnpackedPackage projectRoot+      , srcpkgDescrOverride = Nothing+      }+    genericPackageDescription = emptyGenericPackageDescription+      { GPD.packageDescription = packageDescription }+    packageDescription = emptyPackageDescription+      { package = fakePackageId+      , specVersion = CabalSpecV2_2+      , licenseRaw = Left SPDX.NONE+      }++-- Lenses+-- | A lens for the 'srcpkgDescription' field of 'SourcePackage'+lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription+lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s))+{-# inline lSrcpkgDescription #-}++lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]+lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s))+{-# inline lLocalPackages #-}++lProjectConfig :: Lens' ProjectBaseContext ProjectConfig+lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s))+{-# inline lProjectConfig #-}++-- Character classes+-- Transcribed from "templates/Lexer.x"+ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char+ccSpace     = S.fromList " "+ccCtrlchar  = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]+ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar+ccSymbol'   = S.fromList ",=<>+*&|!$%^@#?/\\~"+ccParen     = S.fromList "()[]"+ccNamecore  = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']
src/Distribution/Client/Security/HTTP.hs view
@@ -119,11 +119,16 @@     rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)  mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]-mkReqHeaders reqHeaders mRange = concat [+mkReqHeaders reqHeaders mRange' = concat [       tr [] reqHeaders     , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]     ]   where+    -- guard against malformed range headers.+    mRange = case mRange' of+        Just (fr, to) | fr >= to -> Nothing+        _ -> mRange'+     tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]     tr acc [] =       concatMap finalize acc
src/Distribution/Client/Setup.hs view
@@ -34,7 +34,6 @@     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)     , genBoundsCommand-    , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..)     , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , formatCommand@@ -71,7 +70,7 @@ import Distribution.Client.IndexUtils.IndexState          ( TotalIndexState, headTotalIndexState ) import qualified Distribution.Client.Init.Types as IT-         ( InitFlags(..), PackageType(..), defaultInitFlags )+import qualified Distribution.Client.Init.Defaults as IT import Distribution.Client.Targets          ( UserConstraint, readUserConstraint ) import Distribution.Utils.NubList@@ -106,8 +105,6 @@          , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version          ( Version, mkVersion )-import Distribution.Package-         ( PackageName ) import Distribution.Types.GivenComponent          ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint@@ -118,7 +115,7 @@          ( BuildType(..), RepoKind(..), LibraryName(..) ) import Distribution.System ( Platform ) import Distribution.ReadE-         ( ReadE(..), succeedReadE, parsecToReadE )+         ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString ) import qualified Distribution.Compat.CharParsing as P import Distribution.Verbosity          ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )@@ -164,6 +161,7 @@           , "info"           , "user-config"           , "get"+          , "unpack"           , "init"           , "configure"           , "build"@@ -251,6 +249,7 @@         , par         , startGroup "package"         , addCmd "get"+        , addCmd "unpack"         , addCmd "init"         , par         , addCmd "configure"@@ -348,11 +347,6 @@          globalConfigFile (\v flags -> flags { globalConfigFile = v })          (reqArgFlag "FILE") -      ,option [] ["default-user-config"]-         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."-         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})-         (reqArgFlag "FILE")-       ,option [] ["ignore-expiry"]          "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"          globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })@@ -362,14 +356,33 @@          "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"          globalHttpTransport (\v flags -> flags { globalHttpTransport = v })          (reqArgFlag "HttpTransport")-      ,option [] ["nix"]-         "Nix integration: run commands through nix-shell if a 'shell.nix' file exists"-         globalNix (\v flags -> flags { globalNix = v })-         (boolOpt [] []) +      ,multiOption "nix"+        globalNix (\v flags -> flags { globalNix = v })+        [+          noArg (Flag True) [] ["enable-nix"]+          "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists",+          noArg (Flag False) [] ["disable-nix"]+          "Disable Nix integration"+        ]++      ,option [] ["store-dir", "storedir"]+         "The location of the build store"+         globalStoreDir (\v flags -> flags { globalStoreDir = v })+         (reqArgFlag "DIR")++      , option [] ["active-repositories"]+         "The active package repositories (set to ':none' to disable all repositories)"+         globalActiveRepos (\v flags ->  flags { globalActiveRepos = v })+         (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)+                                        (toFlag `fmap` parsec))+                         (map prettyShow . flagToList))       ]      -- arguments we don't want shown in the help+    -- the remote repo flags are not useful compared to the more general "active-repositories" flag.+    -- the global logs directory was only used in v1, while in v2 we have specific project config logs dirs+    -- default-user-config is support for a relatively obscure workflow for v1-freeze.     argsNotShown :: [OptionField GlobalFlags]     argsNotShown = [        option [] ["remote-repo"]@@ -392,22 +405,11 @@          globalLogsDir (\v flags -> flags { globalLogsDir = v })          (reqArgFlag "DIR") -      ,option [] ["world-file"]-         "The location of the world file"-         globalWorldFile (\v flags -> flags { globalWorldFile = v })+      ,option [] ["default-user-config"]+         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."+         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})          (reqArgFlag "FILE") -      ,option [] ["store-dir", "storedir"]-         "The location of the nix-local-build store"-         globalStoreDir (\v flags -> flags { globalStoreDir = v })-         (reqArgFlag "DIR")--      , option [] ["active-repositories"]-         "The active package repositories"-         globalActiveRepos (\v flags ->  flags { globalActiveRepos = v })-         (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)-                                        (toFlag `fmap` parsec))-                         (map prettyShow . flagToList))       ]  -- ------------------------------------------------------------@@ -453,7 +455,7 @@ filterConfigureFlags flags cabalLibVersion   -- NB: we expect the latest version to be the most common case,   -- so test it first.-  | cabalLibVersion >= mkVersion [2,5,0]  = flags_latest+  | cabalLibVersion >= mkVersion [3,7,0]  = flags_latest   -- The naming convention is that flags_version gives flags with   -- all flags *introduced* in version eliminated.   -- It is NOT the latest version of Cabal library that@@ -473,6 +475,7 @@   | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0   | cabalLibVersion < mkVersion [2,1,0]  = flags_2_1_0   | cabalLibVersion < mkVersion [2,5,0]  = flags_2_5_0+  | cabalLibVersion < mkVersion [3,7,0]  = flags_3_7_0   | otherwise = error "the impossible just happened" -- see first guard   where     flags_latest = flags        {@@ -483,7 +486,15 @@       configConstraints = []       } -    flags_2_5_0 = flags_latest {+    flags_3_7_0 = flags_latest {+        -- Cabal < 3.7 does not know about --extra-lib-dirs-static+        configExtraLibDirsStatic = [],++        -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info'+        configDumpBuildInfo = NoFlag+      }++    flags_2_5_0 = flags_3_7_0 {       -- Cabal < 2.5 does not understand --dependency=pkg:component=cid       -- (public sublibraries), so we convert it to the legacy       -- --dependency=pkg_or_internal_compoent=cid@@ -599,6 +610,8 @@ -- data ConfigExFlags = ConfigExFlags {     configCabalVersion  :: Flag Version,+    configAppend        :: Flag Bool,+    configBackup        :: Flag Bool,     configExConstraints :: [(UserConstraint, ConstraintSource)],     configPreferences   :: [PackageVersionConstraint],     configSolver        :: Flag PreSolver,@@ -637,7 +650,15 @@       (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)                                     (fmap toFlag parsec))                         (map prettyShow. flagToList))-  , option [] ["constraint"]+  , option "" ["append"]+      "appending the new config to the old config file"+      configAppend (\v flags -> flags { configAppend = v })+      (boolOpt [] [])+  , option "" ["backup"]+      "the backup of the config file before any alterations"+      configBackup (\v flags -> flags { configBackup = v })+      (boolOpt [] [])+  , option "c" ["constraint"]       "Specify constraints on a package (version, installed/source, flags)"       configExConstraints (\v flags -> flags { configExConstraints = v })       (reqArg "CONSTRAINT"@@ -659,7 +680,7 @@     (fmap unAllowOlder . configAllowOlder)     (\v flags -> flags { configAllowOlder = fmap AllowOlder v})     (optArg "DEPS"-     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (parsecToReadEErr unexpectMsgString  relaxDepsParser)      (Just RelaxDepsAll) relaxDepsPrinter)    , option [] ["allow-newer"]@@ -667,7 +688,7 @@     (fmap unAllowNewer . configAllowNewer)     (\v flags -> flags { configAllowNewer = fmap AllowNewer v})     (optArg "DEPS"-     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (parsecToReadEErr unexpectMsgString  relaxDepsParser)      (Just RelaxDepsAll) relaxDepsPrinter)    , option [] ["write-ghc-environment-files"]@@ -699,8 +720,13 @@   relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)-relaxDepsParser =-  (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')+relaxDepsParser = do+  rs <- P.sepBy parsec (P.char ',')+  if null rs+    then fail $ "empty argument list is not allowed. "+             ++ "Note: use --allow-newer without the equals sign to permit all "+             ++ "packages to use newer versions."+    else return . Just . RelaxDepsSome . toList $ rs  relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] relaxDepsPrinter Nothing                     = []@@ -1125,123 +1151,6 @@   }  -- --------------------------------------------------------------- * 'outdated' command--- --------------------------------------------------------------data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone-                             | IgnoreMajorVersionBumpsAll-                             | IgnoreMajorVersionBumpsSome [PackageName]--instance Monoid IgnoreMajorVersionBumps where-  mempty  = IgnoreMajorVersionBumpsNone-  mappend = (<>)--instance Semigroup IgnoreMajorVersionBumps where-  IgnoreMajorVersionBumpsNone       <> r                               = r-  l@IgnoreMajorVersionBumpsAll      <> _                               = l-  l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone     = l-  (IgnoreMajorVersionBumpsSome   _) <> r@IgnoreMajorVersionBumpsAll    = r-  (IgnoreMajorVersionBumpsSome   a) <> (IgnoreMajorVersionBumpsSome b) =-    IgnoreMajorVersionBumpsSome (a ++ b)--data OutdatedFlags = OutdatedFlags {-  outdatedVerbosity     :: Flag Verbosity,-  outdatedFreezeFile    :: Flag Bool,-  outdatedNewFreezeFile :: Flag Bool,-  outdatedProjectFile   :: Flag FilePath,-  outdatedSimpleOutput  :: Flag Bool,-  outdatedExitCode      :: Flag Bool,-  outdatedQuiet         :: Flag Bool,-  outdatedIgnore        :: [PackageName],-  outdatedMinor         :: Maybe IgnoreMajorVersionBumps-  }--defaultOutdatedFlags :: OutdatedFlags-defaultOutdatedFlags = OutdatedFlags {-  outdatedVerbosity     = toFlag normal,-  outdatedFreezeFile    = mempty,-  outdatedNewFreezeFile = mempty,-  outdatedProjectFile   = mempty,-  outdatedSimpleOutput  = mempty,-  outdatedExitCode      = mempty,-  outdatedQuiet         = mempty,-  outdatedIgnore        = mempty,-  outdatedMinor         = mempty-  }--outdatedCommand :: CommandUI OutdatedFlags-outdatedCommand = CommandUI {-  commandName = "outdated",-  commandSynopsis = "Check for outdated dependencies",-  commandDescription  = Just $ \_ -> wrapText $-    "Checks for outdated dependencies in the package description file "-    ++ "or freeze file",-  commandNotes = Nothing,-  commandUsage = usageFlags "outdated",-  commandDefaultFlags = defaultOutdatedFlags,-  commandOptions      = \ _ -> [-    optionVerbosity outdatedVerbosity-      (\v flags -> flags { outdatedVerbosity = v })--    ,option [] ["freeze-file", "v1-freeze-file"]-     "Act on the freeze file"-     outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v })-     trueArg--    ,option [] ["v2-freeze-file", "new-freeze-file"]-     "Act on the new-style freeze file (default: cabal.project.freeze)"-     outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v })-     trueArg--    ,option [] ["project-file"]-     "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze"-     outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v })-     (reqArgFlag "PROJECTFILE")--    ,option [] ["simple-output"]-     "Only print names of outdated dependencies, one per line"-     outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v })-     trueArg--    ,option [] ["exit-code"]-     "Exit with non-zero when there are outdated dependencies"-     outdatedExitCode (\v flags -> flags { outdatedExitCode = v })-     trueArg--    ,option ['q'] ["quiet"]-     "Don't print any output. Implies '--exit-code' and '-v0'"-     outdatedQuiet (\v flags -> flags { outdatedQuiet = v })-     trueArg--   ,option [] ["ignore"]-    "Packages to ignore"-    outdatedIgnore (\v flags -> flags { outdatedIgnore = v })-    (reqArg "PKGS" pkgNameListParser (map prettyShow))--   ,option [] ["minor"]-    "Ignore major version bumps for these packages"-    outdatedMinor (\v flags -> flags { outdatedMinor = v })-    (optArg "PKGS" ignoreMajorVersionBumpsParser-      (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter)-   ]-  }-  where-    ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps)-                                   -> [Maybe String]-    ignoreMajorVersionBumpsPrinter Nothing = []-    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []-    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]-    ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =-      map (Just . prettyShow) $ pkgs--    ignoreMajorVersionBumpsParser  =-      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser--    pkgNameListParser = parsecToReadE-      ("Couldn't parse the list of package names: " ++)-      (fmap toList (P.sepByNonEmpty parsec (P.char ',')))---- ------------------------------------------------------------ -- * Update command -- ------------------------------------------------------------ @@ -1409,17 +1318,8 @@ getCommand = CommandUI {     commandName         = "get",     commandSynopsis     = "Download/Extract a package's source code (repository).",-    commandDescription  = Just $ \_ -> wrapText $-          "Creates a local copy of a package's source code. By default it gets "-       ++ "the source\ntarball and unpacks it in a local subdirectory. "-       ++ "Alternatively, with -s it will\nget the code from the source "-       ++ "repository specified by the package.\n",-    commandNotes        = Just $ \pname ->-          "Examples:\n"-       ++ "  " ++ pname ++ " get hlint\n"-       ++ "    Download the latest stable version of hlint;\n"-       ++ "  " ++ pname ++ " get lens --source-repository=head\n"-       ++ "    Download the source repository (i.e. git clone from github).\n",+    commandDescription  = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand,+    commandNotes        = Just $ \pname -> unlines $ notesOfGetCommand "get" pname,     commandUsage        = usagePackages "get",     commandDefaultFlags = defaultGetFlags,     commandOptions      = \_ -> [@@ -1460,12 +1360,38 @@        ]   } +-- | List of lines describing command @get@.+descriptionOfGetCommand :: [String]+descriptionOfGetCommand =+  [ "Creates a local copy of a package's source code. By default it gets the source"+  , "tarball and unpacks it in a local subdirectory. Alternatively, with -s it will"+  , "get the code from the source repository specified by the package."+  ]++-- | Notes for the command @get@.+notesOfGetCommand+  :: String    -- ^ Either @"get"@ or @"unpack"@.+  -> String    -- ^ E.g. @"cabal"@.+  -> [String]  -- ^ List of lines.+notesOfGetCommand cmd pname =+  [ "Examples:"+  , "  " ++ unwords [ pname, cmd, "hlint" ]+  , "    Download the latest stable version of hlint;"+  , "  " ++ unwords [ pname, cmd, "lens --source-repository=head" ]+  , "    Download the source repository of lens (i.e. git clone from github)."+  ]+ -- 'cabal unpack' is a deprecated alias for 'cabal get'. unpackCommand :: CommandUI GetFlags-unpackCommand = getCommand {-  commandName  = "unpack",-  commandUsage = usagePackages "unpack"+unpackCommand = getCommand+  { commandName        = "unpack"+  , commandSynopsis    = synopsis+  , commandNotes       = Just $ \ pname -> unlines $+      notesOfGetCommand "unpack" pname+  , commandUsage       = usagePackages "unpack"   }+  where+  synopsis = "Deprecated alias for 'get'."  instance Monoid GetFlags where   mempty = gmempty@@ -1532,7 +1458,7 @@         listSimpleOutput (\v flags -> flags { listSimpleOutput = v })         trueArg     , option ['i'] ["ignore-case"]-        "Ignore case destictions"+        "Ignore case distinctions"         listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v })         (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) @@ -1650,7 +1576,6 @@     -- when removing v1 commands     installSymlinkBinDir    :: Flag FilePath,     installPerComponent     :: Flag Bool,-    installOneShot          :: Flag Bool,     installNumJobs          :: Flag (Maybe Int),     installKeepGoing        :: Flag Bool,     installRunTests         :: Flag Bool,@@ -1691,7 +1616,6 @@     installReportPlanningFailure = Flag False,     installSymlinkBinDir   = mempty,     installPerComponent    = Flag True,-    installOneShot         = Flag False,     installNumJobs         = mempty,     installKeepGoing       = Flag False,     installRunTests        = mempty,@@ -1986,11 +1910,6 @@           installPerComponent (\v flags -> flags { installPerComponent = v })           (boolOpt [] []) -      , option [] ["one-shot"]-          "Do not record the packages in the world file."-          installOneShot (\v flags -> flags { installOneShot = v })-          (yesNoOpt showOrParseArgs)-       , option [] ["run-tests"]           "Run package test suites during installation."           installRunTests (\v flags -> flags { installRunTests = v })@@ -2114,20 +2033,19 @@ initCommand :: CommandUI IT.InitFlags initCommand = CommandUI {     commandName = "init",-    commandSynopsis = "Create a new .cabal package file.",+    commandSynopsis = "Create a new cabal package.",     commandDescription = Just $ \_ -> wrapText $-         "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n"+         "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n"       ++ "\n"-      ++ "Calling init with no arguments creates an executable, "-      ++ "guessing as many options as possible. The interactive "-      ++ "mode can be invoked by the -i/--interactive flag, which "-      ++ "will try to guess as much as possible and prompt you for "-      ++ "the rest. You can change init to always be interactive by "-      ++ "setting the interactive flag in your configuration file. "-      ++ "Command-line arguments are provided for scripting purposes.\n",+      ++ "Calling init with no arguments runs interactive mode, "+      ++ "which will try to guess as much as possible and prompt you for the rest.\n"+      ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, "+      ++ "which will let you specify the options via flags and will use the defaults for the rest.\n"+      ++ "It is also possible to call init with a single argument, which denotes the project's desired "+      ++ "root directory.\n",     commandNotes = Nothing,     commandUsage = \pname ->-         "Usage: " ++ pname ++ " init [FLAGS]\n",+         "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n",     commandDefaultFlags = IT.defaultInitFlags,     commandOptions = initOptions   }@@ -2215,14 +2133,17 @@   , option ['c'] ["category"]     "Project category."     IT.category (\v flags -> flags { IT.category = v })-    (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))-                        (flagToList . fmap (either id show)))+    (reqArgFlag "CATEGORY")    , option ['x'] ["extra-source-file"]     "Extra source file to be distributed with tarball."     IT.extraSrc (\v flags -> flags { IT.extraSrc = v })-    (reqArg' "FILE" (Just . (:[]))-                    (fromMaybe []))+    (reqArg' "FILE" (Flag . (:[]))+                    (fromFlagOrDefault []))+  , option [] ["extra-doc-file"]+    "Extra doc file to be distributed with tarball."+    IT.extraDoc (\v flags -> flags { IT.extraDoc = v })+    (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault []))    , option [] ["lib", "is-library"]     "Build a library."@@ -2242,7 +2163,7 @@     (noArg (Flag IT.LibraryAndExecutable))        , option [] ["tests"]-        "Generate a test suite for the library."+        "Generate a test suite, standalone or for a library."         IT.initializeTestSuite         (\v flags -> flags { IT.initializeTestSuite = v })         trueArg@@ -2250,8 +2171,8 @@       , option [] ["test-dir"]         "Directory containing tests."         IT.testDirs (\v flags -> flags { IT.testDirs = v })-        (reqArg' "DIR" (Just . (:[]))-                       (fromMaybe []))+        (reqArg' "DIR" (Flag . (:[]))+                       (fromFlagOrDefault []))    , option [] ["simple"]     "Create a simple project with sensible defaults."@@ -2278,47 +2199,45 @@     IT.exposedModules     (\v flags -> flags { IT.exposedModules = v })     (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)-                                 ((Just . (:[])) `fmap` parsec))-                     (maybe [] (fmap prettyShow)))+                                 (Flag . (:[]) <$> parsec))+                     (flagElim [] (fmap prettyShow)))    , option [] ["extension"]     "Use a LANGUAGE extension (in the other-extensions field)."     IT.otherExts     (\v flags -> flags { IT.otherExts = v })     (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)-                                    ((Just . (:[])) `fmap` parsec))-                        (maybe [] (fmap prettyShow)))+                                    (Flag . (:[]) <$> parsec))+                        (flagElim [] (fmap prettyShow)))    , option ['d'] ["dependency"]     "Package dependency."     IT.dependencies (\v flags -> flags { IT.dependencies = v })     (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++)-                                  ((Just . (:[])) `fmap` parsec))-                      (maybe [] (fmap prettyShow)))+                                  (Flag . (:[]) <$> parsec))+                      (flagElim [] (fmap prettyShow)))    , option [] ["application-dir"]     "Directory containing package application executable."     IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v})-    (reqArg' "DIR" (Just . (:[]))-                   (fromMaybe []))+    (reqArg' "DIR" (Flag . (:[]))+                   (fromFlagOrDefault []))    , option [] ["source-dir", "sourcedir"]     "Directory containing package library source."     IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })-    (reqArg' "DIR" (Just . (:[]))-                   (fromMaybe []))+    (reqArg' "DIR" (Flag. (:[]))+                   (fromFlagOrDefault []))    , option [] ["build-tool"]     "Required external build tool."     IT.buildTools (\v flags -> flags { IT.buildTools = v })-    (reqArg' "TOOL" (Just . (:[]))-                    (fromMaybe []))+    (reqArg' "TOOL" (Flag . (:[]))+                    (fromFlagOrDefault [])) -    -- NB: this is a bit of a transitional hack and will likely be-    -- removed again if `cabal init` is migrated to the v2-* command-    -- framework   , option "w" ["with-compiler"]-    "give the path to a particular compiler"+    "give the path to a particular compiler. For 'init', this flag is used \+    \to set the bounds inferred for the 'base' package."     IT.initHcPath (\v flags -> flags { IT.initHcPath = v })     (reqArgFlag "PATH")
src/Distribution/Client/SetupWrapper.hs view
@@ -43,14 +43,14 @@          , PackageDescription(..), specVersion, buildType          , BuildType(..) ) import Distribution.Types.ModuleRenaming (defaultRenaming)-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription ) import Distribution.Simple.Configure          ( configCompilerEx ) import Distribution.Compiler          ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) import Distribution.Simple.Compiler          ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack )+import Distribution.Simple.PackageDescription+         ( readGenericPackageDescription ) import Distribution.Simple.PreProcess          ( runSimplePreProcessor, ppUnlit ) import Distribution.Simple.Build.Macros
src/Distribution/Client/SolverInstallPlan.hs view
@@ -126,6 +126,7 @@     comps | null deps = ""           | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)       where+        deps :: Set CD.Component         deps = CD.components (solverPkgLibDeps spkg)              <> CD.components (solverPkgExeDeps spkg) @@ -271,6 +272,7 @@                 -> SolverPlanIndex nonSetupClosure index pkgids0 = closure Graph.empty pkgids0  where+    closure :: Graph SolverPlanPackage -> [SolverId] -> SolverPlanIndex     closure completed []             = completed     closure completed (pkgid:pkgids) =       case Graph.lookup pkgid index of@@ -293,6 +295,7 @@        if indepGoals then map (:[]) libRoots else [libRoots]     ++ setupRoots index   where+    libRoots :: [SolverId]     libRoots = libraryRoots index  -- | Compute the library roots of a plan
src/Distribution/Client/SourceFiles.hs view
@@ -12,15 +12,19 @@ -- we cannot "see" easily. module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where +import Control.Monad.IO.Class+ import Distribution.Client.ProjectPlanning.Types import Distribution.Client.RebuildMonad  import Distribution.Solver.Types.OptionalStanza +import Distribution.Simple.Glob (matchDirFileGlobWithDie) import Distribution.Simple.PreProcess  import Distribution.Types.PackageDescription import Distribution.Types.Component+import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec) import Distribution.Types.Library import Distribution.Types.Executable import Distribution.Types.Benchmark@@ -35,6 +39,7 @@  import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Verbosity (silent)  import System.FilePath @@ -48,8 +53,11 @@ needElaboratedPackage elab epkg =     traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)   where+    pkg_descr :: PackageDescription     pkg_descr = elabPkgDescription elab+    enabled_stanzas :: OptionalStanzaSet     enabled_stanzas = pkgStanzasEnabled epkg+    enabled :: ComponentRequestedSpec     enabled = enableStanzas enabled_stanzas  needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild ()@@ -58,7 +66,9 @@         Nothing   -> needSetup         Just comp -> needComponent pkg_descr comp   where+    pkg_descr :: PackageDescription     pkg_descr = elabPkgDescription elab+    mb_comp   :: Maybe Component     mb_comp   = fmap (getComponent pkg_descr) (compComponentName ecomp)  needComponent :: PackageDescription -> Component -> Rebuild ()@@ -101,6 +111,7 @@         needBuildInfo pkg_descr bi [m]       TestSuiteUnsupported _ -> return () -- soft fail  where+  bi :: BuildInfo   bi = testBuildInfo t  needMainFile :: BuildInfo -> FilePath -> Rebuild ()@@ -130,6 +141,7 @@        needMainFile  bi mainPath      BenchmarkUnsupported _ -> return () -- soft fail  where+  bi :: BuildInfo   bi = benchmarkBuildInfo bm  needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild ()@@ -138,21 +150,24 @@     -- A.hs-boot; need to track both.     findNeededModules ["hs", "lhs", "hsig", "lhsig"]     findNeededModules ["hs-boot", "lhs-boot"]+    expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie silent (\ _ _ -> return []) (specVersion pkg_descr) "." fpath     traverse_ needIfExists $ concat         [ cSources bi         , cxxSources bi         , jsSources bi         , cmmSources bi         , asmSources bi-        , extraSrcFiles pkg_descr+        , expandedExtraSrcFiles         ]     for_ (installIncludes bi) $ \f ->         findFileMonitored ("." : includeDirs bi) f             >>= maybe (return ()) need   where+    findNeededModules :: [String] -> Rebuild ()     findNeededModules exts = traverse_         (findNeededModule exts)         (modules ++ otherModules bi)+    findNeededModule :: [String] -> ModuleName -> Rebuild ()     findNeededModule exts m =         findFileWithExtensionMonitored             (ppSuffixes knownSuffixHandlers ++ exts)
src/Distribution/Client/SrcDist.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}--- | Utilities to implemenet cabal @v2-sdist@.+-- | Utilities to implement cabal @v2-sdist@. module Distribution.Client.SrcDist (     allPackageSourceFiles,     packageDirToSdist,@@ -16,7 +16,7 @@ import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc) import Distribution.Package                          (Package (packageId)) import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)+import Distribution.Simple.PackageDescription        (readGenericPackageDescription) import Distribution.Simple.PreProcess                (knownSuffixHandlers) import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie) import Distribution.Simple.Utils                     (die')@@ -55,7 +55,8 @@         thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s      files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers-    let files = nub $ sort $ map normalise files'+    let files :: [FilePath]+        files = nub $ sort $ map normalise files'      let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()         entriesM = do@@ -91,5 +92,6 @@         -- Windows; we need a post-1980 date. One gigasecond         -- after the epoch is during 2001-09-09, so that does         -- nicely. See #5596.+        setModTime :: Tar.Entry -> Tar.Entry         setModTime entry = entry { Tar.entryTime = 1000000000 }     return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
src/Distribution/Client/TargetSelector.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,              RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- TODO {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -----------------------------------------------------------------------------@@ -92,7 +94,7 @@          ( doesFileExist, doesDirectoryExist, canonicalizePath          , getCurrentDirectory ) import System.FilePath-         ( (</>), (<.>), normalise, dropTrailingPathSeparator )+         ( (</>), (<.>), normalise, dropTrailingPathSeparator, equalFilePath ) import Text.EditDistance          ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) import Distribution.Utils.Path@@ -202,7 +204,7 @@ readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]                     -> Maybe ComponentKindFilter                     -- ^ This parameter is used when there are ambiguous selectors.-                    --   If it is 'Just', then we attempt to resolve ambiguitiy+                    --   If it is 'Just', then we attempt to resolve ambiguity                     --   by applying it, since otherwise there is no way to allow                     --   contextually valid yet syntactically ambiguous selectors.                     --   (#4676, #5461)@@ -465,8 +467,9 @@ resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =     ([TargetSelectorNoTargetsInProject], []) -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ =-    ([TargetSelectorNoTargetsInCwd], [])+-- if the component kind filter is just exes, we don't want to suggest "all" as a target.+resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf =+    ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) ], [])  resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =     ([], [TargetPackage TargetImplicitCwd pkgids Nothing])@@ -591,8 +594,10 @@    | TargetSelectorUnrecognised String      -- ^ Syntax error when trying to parse a target string.    | TargetSelectorNoCurrentPackage TargetString-   | TargetSelectorNoTargetsInCwd+   | TargetSelectorNoTargetsInCwd Bool+     -- ^ bool that flags when it is acceptable to suggest "all" as a target    | TargetSelectorNoTargetsInProject+   | TargetSelectorNoScript TargetString   deriving (Show, Eq)  -- | Qualification levels.@@ -791,7 +796,7 @@         --TODO: report a different error if there is a .cabal file but it's         -- not a member of the project -    case [ () | TargetSelectorNoTargetsInCwd <- problems ] of+    case [ () | TargetSelectorNoTargetsInCwd True <- problems ] of       []  -> return ()       _:_ ->         die' verbosity $@@ -800,6 +805,14 @@          ++ "project or specify packages or components by name or location. "          ++ "See 'cabal build --help' for more details on target options." +    case [ () | TargetSelectorNoTargetsInCwd False <- problems ] of+      []  -> return ()+      _:_ ->+        die' verbosity $+            "No targets given and there is no package in the current "+         ++ "directory. Specify packages or components by name or location. "+         ++ "See 'cabal build --help' for more details on target options."+     case [ () | TargetSelectorNoTargetsInProject <- problems ] of       []  -> return ()       _:_ ->@@ -813,6 +826,14 @@          ++ "packages in your project and all other build configuration. "          ++ "See the Cabal user guide for full details." +    case [ t | TargetSelectorNoScript t <- problems ] of+      []  -> return ()+      target:_ ->+        die' verbosity $+            "The script '" ++ showTargetString target ++ "' does not exist, "+         ++ "and only script targets may contain whitespace characters or end "+         ++ "with ':'"+     fail "reportTargetSelectorProblems: internal error"  @@ -1746,14 +1767,14 @@ emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] -getKnownTargets :: (Applicative m, Monad m)+getKnownTargets :: forall m a. (Applicative m, Monad m)                 => DirActions m                 -> [PackageSpecifier (SourcePackage (PackageLocation a))]                 -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do     pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs     cwd   <- getCurrentDirectory-    let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo+    (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo     return KnownTargets {       knownPackagesAll       = pinfo,       knownPackagesPrimary   = ppinfo,@@ -1763,14 +1784,19 @@       knownComponentsOther   = allComponentsIn opinfo     }   where+    mPkgDir :: KnownPackage -> Maybe FilePath+    mPkgDir KnownPackage { pinfoDirectory = Just (dir,_) } = Just dir+    mPkgDir _ = Nothing+     selectPrimaryPackage :: FilePath                          -> [KnownPackage]-                         -> ([KnownPackage], [KnownPackage])-    selectPrimaryPackage cwd = partition isPkgDirCwd-      where-        isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) }-          | dir == cwd = True-        isPkgDirCwd _  = False+                         -> m ([KnownPackage], [KnownPackage])+    selectPrimaryPackage _ [] = return ([] , [])+    selectPrimaryPackage cwd (pkg : packages) = do+      (ppinfo, opinfo) <- selectPrimaryPackage cwd packages+      isPkgDirCwd <- maybe (pure False) (compareFilePath dirActions cwd) (mPkgDir pkg)+      return (if isPkgDirCwd then (pkg : ppinfo, opinfo) else (ppinfo, pkg : opinfo))+     allComponentsIn ps =       [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] @@ -2164,6 +2190,18 @@                                       -- is stored without the extension  -- utils++-- | Compare two filepaths for equality using DirActions' canonicalizePath+-- to normalize AND canonicalize filepaths before comparison.+compareFilePath :: (Applicative m, Monad m) => DirActions m+                -> FilePath -> FilePath -> m Bool+compareFilePath DirActions{..} fp1 fp2+  | equalFilePath fp1 fp2 = pure True -- avoid unnecessary IO if we can match earlier+  | otherwise = do+    c1 <- canonicalizePath fp1+    c2 <- canonicalizePath fp2+    pure $ equalFilePath c1 c2+  matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) matchFile fs =
src/Distribution/Client/Targets.hs view
@@ -53,7 +53,6 @@ import Distribution.Package          ( Package(..), PackageName, unPackageName, mkPackageName          , packageName )-import Distribution.Types.Dependency import Distribution.Client.Types          ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage          , PackageSpecifier(..) )@@ -65,7 +64,6 @@ import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import           Distribution.Solver.Types.SourcePackage -import qualified Distribution.Client.World as World import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar@@ -79,14 +77,16 @@ import Distribution.PackageDescription          ( GenericPackageDescription ) import Distribution.Types.Flag-         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty )+         ( parsecFlagAssignmentNonEmpty ) import Distribution.Version-         ( anyVersion, isAnyVersion )+         ( isAnyVersion ) import Distribution.Simple.Utils-         ( die', warn, lowercase )+         ( die', lowercase )  import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )+         ( parseGenericPackageDescriptionMaybe )+import Distribution.Simple.PackageDescription+         ( readGenericPackageDescription )  import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS@@ -116,13 +116,6 @@      --      UserTargetNamed PackageVersionConstraint -     -- | A special virtual package that refers to the collection of packages-     -- recorded in the world file that the user specifically installed.-     ---     -- > cabal install world-     ---   | UserTargetWorld-      -- | A specific package that is unpacked in a local directory, often the      -- current directory.      --@@ -174,17 +167,11 @@    | UserTargetUnexpectedUriScheme String    | UserTargetUnrecognisedUri     String    | UserTargetUnrecognised        String-   | UserTargetBadWorldPkg   deriving Show  readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr =     case eitherParsec targetstr of-      Right (PackageVersionConstraint pkgn verrange)-        | pkgn == mkPackageName "world"-          -> return $ if verrange == anyVersion-                      then Right UserTargetWorld-                      else Left  UserTargetBadWorldPkg       Right dep -> return (Right (UserTargetNamed dep))       Left _err -> do         fileTarget <- testFileTargets targetstr@@ -195,13 +182,15 @@               Just target -> return target               Nothing     -> return (Left (UserTargetUnrecognised targetstr))   where+    testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget))     testFileTargets filename = do       isDir  <- doesDirectoryExist filename       isFile <- doesFileExist filename       parentDirExists <- case takeDirectory filename of                            []  -> return False                            dir -> doesDirectoryExist dir-      let result+      let result :: Maybe (Either UserTargetProblem UserTarget)+          result             | isDir             = Just (Right (UserTargetLocalDir filename)) @@ -221,6 +210,7 @@             = Nothing       return result +    testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget)     testUriTargets str =       case parseAbsoluteURI str of         Just uri@URI {@@ -237,6 +227,7 @@             Just (Right (UserTargetRemoteTarball uri))         _ -> Nothing +    extensionIsTarGz :: FilePath -> Bool     extensionIsTarGz f = takeExtension f                 == ".gz"                       && takeExtension (dropExtension f) == ".tar" @@ -250,14 +241,9 @@                   | name <- target ]              ++ "Targets can be:\n"              ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"-             ++ " - the special 'world' target\n"              ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"              ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" -    case [ () | UserTargetBadWorldPkg <- problems ] of-      [] -> return ()-      _  -> die' verbosity "The special 'world' target does not take any version."-     case [ target | UserTargetNonexistantFile target <- problems ] of       []     -> return ()       target -> die' verbosity@@ -301,24 +287,24 @@ resolveUserTargets :: Package pkg                    => Verbosity                    -> RepoContext-                   -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]                    -> IO [PackageSpecifier UnresolvedSourcePackage]-resolveUserTargets verbosity repoCtxt worldFile available userTargets = do+resolveUserTargets verbosity repoCtxt available userTargets = do      -- given the user targets, get a list of fully or partially resolved     -- package references     packageTargets <- traverse (readPackageTarget verbosity)                   =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat-                  =<< traverse (expandUserTarget verbosity worldFile) userTargets+                  =<< traverse (expandUserTarget verbosity) userTargets      -- users are allowed to give package names case-insensitively, so we must     -- disambiguate named package references-    let (problems, packageSpecifiers) =+    let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) =            disambiguatePackageTargets available availableExtra packageTargets          -- use any extra specific available packages to help us disambiguate+        availableExtra :: [PackageName]         availableExtra = [ packageName pkg                          | PackageTargetLocation pkg <- packageTargets ] @@ -352,26 +338,15 @@ -- (each of which refers to only one package). -- expandUserTarget :: Verbosity-                 -> FilePath                  -> UserTarget                  -> IO [PackageTarget (PackageLocation ())]-expandUserTarget verbosity worldFile userTarget = case userTarget of+expandUserTarget verbosity userTarget = case userTarget of      UserTargetNamed (PackageVersionConstraint name vrange) ->       let props = [ PackagePropertyVersion vrange                   | not (isAnyVersion vrange) ]       in  return [PackageTargetNamedFuzzy name props userTarget] -    UserTargetWorld -> do-      worldPkgs <- World.getContents verbosity worldFile-      --TODO: should we warn if there are no world targets?-      return [ PackageTargetNamed name props userTarget-             | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs-             , let props = [ PackagePropertyVersion vrange-                           | not (isAnyVersion vrange) ]-                        ++ [ PackagePropertyFlags flags-                           | not (nullFlagAssignment flags) ] ]-     UserTargetLocalDir dir ->       return [ PackageTargetLocation (LocalUnpackedPackage dir) ] @@ -414,6 +389,7 @@                   -> IO (PackageTarget UnresolvedSourcePackage) readPackageTarget verbosity = traverse modifyLocation   where+    modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage     modifyLocation location = case location of        LocalUnpackedPackage dir -> do@@ -444,6 +420,7 @@         --         -- When that is corrected, this will also need to be fixed. +    readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage     readTarballPackageTarget location tarballFile tarballOriginalLoc = do       (filename, content) <- extractTarballPackageCabalFile                                tarballFile tarballOriginalLoc@@ -471,6 +448,8 @@       where         formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg +        accumEntryMap :: Tar.Entries Tar.FormatError+                      -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry)         accumEntryMap = Tar.foldlEntries                           (\m e -> Map.insert (Tar.entryTarPath e) e m)                           Map.empty@@ -486,6 +465,7 @@             noCabalFile        = "No cabal file found"             multipleCabalFiles = "Multiple cabal files found" +        isCabalFile :: Tar.Entry -> Bool         isCabalFile e = case splitPath (Tar.entryPath e) of           [     _dir, file] -> takeExtension file == ".cabal"           [".", _dir, file] -> takeExtension file == ".cabal"@@ -544,8 +524,7 @@ reportPackageTargetProblems :: Verbosity                             -> [PackageTargetProblem] -> IO () reportPackageTargetProblems verbosity problems = do-    case [ pkg | PackageNameUnknown pkg originalTarget <- problems-               , not (isUserTagetWorld originalTarget) ] of+    case [ pkg | PackageNameUnknown pkg _ <- problems ] of       []    -> return ()       pkgs  -> die' verbosity $ unlines                        [ "There is no package named '" ++ prettyShow name ++ "'. "@@ -564,17 +543,7 @@                            ++ "."                          | (name, matches) <- ambiguities ] -    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of-      []   -> return ()-      pkgs -> warn verbosity $-                 "The following 'world' packages will be ignored because "-              ++ "they refer to packages that cannot be found: "-              ++ intercalate ", " (map prettyShow pkgs) ++ "\n"-              ++ "You can suppress this warning by correcting the world file."-  where-    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False - -- ------------------------------------------------------------ -- * Disambiguating package names -- ------------------------------------------------------------@@ -589,7 +558,7 @@ -- the result is 'Ambiguous'. -- -- Note: Before cabal 2.2, when only a single package matched---       case-insensitively it would be considered 'Unambigious'.+--       case-insensitively it would be considered 'Unambiguous'. -- disambiguatePackageName :: PackageNameEnv                         -> PackageName
src/Distribution/Client/Types/ConfiguredId.hs view
@@ -26,7 +26,7 @@ -- -- The package management layer does however deal with installed packages, as -- whole packages not just as libraries. So we do still need a type for--- installed package ids. At the moment however we track instaled packages via+-- installed package ids. At the moment however we track installed packages via -- their primary library, which is a unit id. In future this may change -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler.
src/Distribution/Client/Types/OverwritePolicy.hs view
@@ -10,6 +10,7 @@ data OverwritePolicy     = NeverOverwrite     | AlwaysOverwrite+    | PromptOverwrite   deriving (Show, Eq, Generic, Bounded, Enum)  instance Binary OverwritePolicy@@ -21,8 +22,10 @@         case name of             "always" -> pure AlwaysOverwrite             "never"  -> pure NeverOverwrite+            "prompt" -> pure PromptOverwrite             _        -> P.unexpected $ "OverwritePolicy: " ++ name  instance Pretty OverwritePolicy where     pretty NeverOverwrite  = PP.text "never"     pretty AlwaysOverwrite = PP.text "always"+    pretty PromptOverwrite = PP.text "prompt"
src/Distribution/Client/Types/Repo.hs view
@@ -71,7 +71,7 @@         pretty (remoteRepoName r) <<>> Disp.colon <<>>         Disp.text (uriToString id (remoteRepoURI r) []) --- | Note: serialised format represends 'RemoteRepo' only partially.+-- | Note: serialised format represents 'RemoteRepo' only partially. instance Parsec RemoteRepo where     parsec = do         name <- parsec@@ -150,7 +150,7 @@       , repoLocalDir :: FilePath       } -    -- | Standard (unsecured) remote repositores+    -- | Standard (unsecured) remote repositories   | RepoRemote {         repoRemote   :: RemoteRepo       , repoLocalDir :: FilePath
src/Distribution/Client/Types/RepoName.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Client.Types.RepoName (     RepoName (..),-    unRepoName, ) where  import Distribution.Client.Compat.Prelude@@ -17,11 +16,8 @@ -- -- May be used as path segment. ---newtype RepoName = RepoName String+newtype RepoName = RepoName { unRepoName :: String }   deriving (Show, Eq, Ord, Generic)--unRepoName :: RepoName -> String-unRepoName (RepoName n) = n  instance Binary RepoName instance Structured RepoName
src/Distribution/Client/Types/SourcePackageDb.hs view
@@ -1,17 +1,23 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Client.Types.SourcePackageDb (     SourcePackageDb (..),+    lookupDependency,+    lookupPackageName, ) where  import Distribution.Client.Compat.Prelude import Prelude ()  import Distribution.Types.PackageName  (PackageName)-import Distribution.Types.VersionRange (VersionRange)+import Distribution.Types.VersionRange (VersionRange, withinRange)+import Distribution.Package            (packageVersion)  import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage)+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.PackageIndex    (PackageIndex) +import qualified Data.Map as Map+ -- | This is the information we get from a @00-index.tar.gz@ hackage index. -- data SourcePackageDb = SourcePackageDb@@ -21,3 +27,38 @@   deriving (Eq, Generic)  instance Binary SourcePackageDb++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+-- Additionally, `preferred-versions` (such as version deprecation) are+-- honoured in this lookup, which is the only difference to+-- 'PackageIndex.lookupDependency'+lookupDependency :: SourcePackageDb -> PackageName -> VersionRange -> [UnresolvedSourcePackage]+lookupDependency sourceDb pname version =+  filterPreferredVersions pref $ PackageIndex.lookupDependency (packageIndex sourceDb) pname version+  where+    pref = Map.lookup pname (packagePreferences sourceDb)+++-- | Does a case-sensitive search by package name.+--+-- Additionally, `preferred-versions` (such as version deprecation) are+-- honoured in this lookup, which is the only difference to+-- 'PackageIndex.lookupPackageName'+lookupPackageName :: SourcePackageDb -> PackageName -> [UnresolvedSourcePackage]+lookupPackageName sourceDb pname =+  filterPreferredVersions pref $ PackageIndex.lookupPackageName (packageIndex sourceDb) pname+  where+    pref = Map.lookup pname (packagePreferences sourceDb)++-- | @filterPreferredVersions 'range' 'versions'@.+-- If a 'range' is given, only keep versions that satisfy the range.+-- If 'range' is 'Nothing', all versions are kept.+--+-- The 'range' is expected to be obtained from the 'SourcePackageDb.packagePreferences'.+filterPreferredVersions :: Maybe VersionRange -> [UnresolvedSourcePackage] -> [UnresolvedSourcePackage]+filterPreferredVersions Nothing versions = versions+filterPreferredVersions (Just range) versions = filter ((`withinRange` range) . packageVersion) versions
src/Distribution/Client/Upload.hs view
@@ -4,7 +4,7 @@ import qualified Prelude as Unsafe (tail, head, read)  import Distribution.Client.Types.Credentials ( Username(..), Password(..) )-import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote)+import Distribution.Client.Types.Repo (Repo, RemoteRepo(..), maybeRepoRemote) import Distribution.Client.Types.RepoName (unRepoName) import Distribution.Client.HttpUtils          ( HttpTransport(..), remoteRepoTryUpgradeToHttps )@@ -12,6 +12,7 @@          ( IsCandidate(..), RepoContext(..) )  import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS)+import Distribution.Utils.String (trim) import Distribution.Client.Config  import qualified Distribution.Client.BuildReports.Anonymous as BuildReport@@ -44,15 +45,19 @@        -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]        -> IO () upload verbosity repoCtxt mUsername mPassword isCandidate paths = do-    let repos = repoContextRepos repoCtxt+    let repos :: [Repo]+        repos = repoContextRepos repoCtxt     transport  <- repoContextGetTransport repoCtxt     targetRepo <-       case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of         [] -> die' verbosity "Cannot upload. No remote repositories are configured."         (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))-    let targetRepoURI = remoteRepoURI targetRepo+    let targetRepoURI :: URI+        targetRepoURI = remoteRepoURI targetRepo+        domain :: String         domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI         rootIfEmpty x = if null x then "/" else x+        uploadURI :: URI         uploadURI = targetRepoURI {             uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>               case isCandidate of@@ -167,16 +172,20 @@  report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () report verbosity repoCtxt mUsername mPassword = do-  let repos       = repoContextRepos repoCtxt+  let repos       :: [Repo]+      repos       = repoContextRepos repoCtxt+      remoteRepos :: [RemoteRepo]       remoteRepos = mapMaybe maybeRepoRemote repos   for_ remoteRepos $ \remoteRepo -> do       let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)       Username username <- maybe (promptUsername domain) return mUsername       Password password <- maybe (promptPassword domain) return mPassword-      let auth        = (username, password)+      let auth        :: (String, String)+          auth        = (username, password)        dotCabal <- getCabalDir-      let srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)+      let srcDir :: FilePath+          srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)       -- We don't want to bomb out just because we haven't built any packages       -- from this repo yet.       srcExists <- doesDirectoryExist srcDir@@ -208,6 +217,7 @@                           ++ err           exitFailure  where+  okMessage :: IsCandidate -> String   okMessage IsCandidate =     "Package successfully uploaded as candidate. "     ++ "You can now preview the result at '" ++ show packageUri@@ -219,7 +229,3 @@ formatWarnings :: String -> String formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x --- Trim-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace
src/Distribution/Client/Utils.hs view
@@ -1,27 +1,34 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-} -module Distribution.Client.Utils ( MergeResult(..)-                                 , mergeBy, duplicates, duplicatesBy-                                 , readMaybe-                                 , inDir, withEnv, withEnvOverrides-                                 , logDirChange, withExtraPathEnv-                                 , determineNumJobs, numberOfProcessors-                                 , removeExistingFile-                                 , withTempFileName-                                 , makeAbsoluteToCwd-                                 , makeRelativeToCwd, makeRelativeToDir-                                 , makeRelativeCanonical-                                 , filePathToByteString-                                 , byteStringToFilePath, tryCanonicalizePath-                                 , canonicalizePathNoThrow-                                 , moreRecentFile, existsAndIsMoreRecentThan-                                 , tryFindAddSourcePackageDesc-                                 , tryFindPackageDesc-                                 , relaxEncodingErrors-                                 , ProgressPhase (..)-                                 , progressMessage-                                 , cabalInstallVersion)-       where+module Distribution.Client.Utils+  ( MergeResult(..)+  , mergeBy, duplicates, duplicatesBy+  , readMaybe+  , inDir, withEnv, withEnvOverrides+  , logDirChange, withExtraPathEnv+  , determineNumJobs, numberOfProcessors+  , removeExistingFile+  , withTempFileName+  , makeAbsoluteToCwd+  , makeRelativeToCwd, makeRelativeToDir+  , makeRelativeCanonical+  , filePathToByteString+  , byteStringToFilePath, tryCanonicalizePath+  , canonicalizePathNoThrow+  , moreRecentFile, existsAndIsMoreRecentThan+  , tryFindAddSourcePackageDesc+  , tryFindPackageDesc+  , findOpenProgramLocation+  , relaxEncodingErrors+  , ProgressPhase (..)+  , progressMessage+  , pvpize+  , incVersion+  , getCurrentYear+  , listFilesRecursive+  , listFilesInside+  , safeRead+  ) where  import Prelude () import Distribution.Client.Compat.Prelude@@ -31,6 +38,7 @@ import Distribution.Simple.Setup       ( Flag(..) ) import Distribution.Version import Distribution.Simple.Utils       ( die', findPackageDesc, noticeNoWrap )+import Distribution.System             ( Platform (..), OS(..)) import qualified Data.ByteString.Lazy as BS import Data.Bits          ( (.|.), shiftL, shiftR )@@ -41,10 +49,12 @@          ( groupBy ) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception-         ( finally, bracket )+         ( finally )+import qualified Control.Exception.Safe as Safe+         ( bracket ) import System.Directory-         ( canonicalizePath, doesFileExist, getCurrentDirectory-         , removeFile, setCurrentDirectory )+         ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory+         , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist ) import System.IO          ( Handle, hClose, openTempFile          , hGetEncoding, hSetEncoding@@ -55,21 +65,22 @@          ( recover, TextEncoding(TextEncoding) ) import GHC.IO.Encoding.Failure          ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )-+import Data.Time.Clock.POSIX (getCurrentTime)+import Data.Time.LocalTime (getCurrentTimeZone, localDay)+import Data.Time (utcToLocalTime)+import Data.Time.Calendar (toGregorian) #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import qualified System.Directory as Dir import qualified System.IO.Error as IOError #endif -#ifndef __DOCTEST__-import qualified Paths_cabal_install (version)-#endif  -- | Generic merging utility. For sorted input lists this is a full outer join. ---mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] mergeBy cmp = merge   where+    merge               :: [a] -> [b] -> [MergeResult a b]     merge []     ys     = [ OnlyInRight y | y <- ys]     merge xs     []     = [ OnlyInLeft  x | x <- xs]     merge (x:xs) (y:ys) =@@ -83,9 +94,10 @@ duplicates :: Ord a => [a] -> [[a]] duplicates = duplicatesBy compare -duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]+duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]] duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp   where+    eq :: a -> a -> Bool     eq a b = case cmp a b of                EQ -> True                _  -> False@@ -108,7 +120,7 @@                  -> String                  -> (FilePath -> IO a) -> IO a withTempFileName tmpDir template action =-  Exception.bracket+  Safe.bracket     (openTempFile tmpDir template)     (\(name, _) -> removeExistingFile name)     (\(name, h) -> hClose h >> action name)@@ -166,7 +178,9 @@ withExtraPathEnv :: [FilePath] -> IO a -> IO a withExtraPathEnv paths m = do   oldPathSplit <- getSearchPath-  let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)+  let newPath :: String+      newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)+      oldPath :: String       oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit       -- TODO: This is a horrible hack to work around the fact that       -- setEnv can't take empty values as an argument@@ -225,9 +239,10 @@   | takeDrive path /= takeDrive dir = path   | otherwise                       = go (splitPath path) (splitPath dir)   where-    go (p:ps) (d:ds) | p == d = go ps ds-    go    []     []           = "./"-    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)+    go (p:ps) (d:ds) | p' == d' = go ps ds+      where (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d)+    go    []     []             = "./"+    go    ps     ds             = joinPath (replicate (length ds) ".." ++ ps)  -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is -- encoded as a little-endian 'Word32'.@@ -337,6 +352,26 @@         Right file -> return file         Left _ -> die' verbosity err +findOpenProgramLocation :: Platform -> IO (Either String FilePath)+findOpenProgramLocation (Platform _ os) =+  let+    locate name = do+      exe <- findExecutable name+      case exe of+        Just s -> pure (Right s)+        Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`"))+    xdg = locate "xdg-open"+  in case os of+    Windows -> pure (Right "start")+    OSX -> locate "open"+    Linux -> xdg+    FreeBSD -> xdg+    OpenBSD -> xdg+    NetBSD -> xdg+    DragonFly -> xdg+    _ -> pure (Left ("Couldn't determine file-opener program for " <> show os))++ -- | Phase of building a dependency. Represents current status of package -- dependency processing. See #4040 for details. data ProgressPhase@@ -361,9 +396,87 @@         ProgressInstalling  -> "Installing   "         ProgressCompleted   -> "Completed    " -cabalInstallVersion :: Version-#ifdef __DOCTEST__-cabalInstallVersion = mkVersion [3,3]-#else-cabalInstallVersion = mkVersion' Paths_cabal_install.version-#endif++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- If the boolean argument denotes whether to use a desugared+-- representation (if 'True') or the new-style @^>=@-form (if+-- 'False').+--+-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the+-- same as @0.4.*@).+pvpize :: Bool -> Version -> VersionRange+pvpize False  v = majorBoundVersion v+pvpize True   v = orLaterVersion v'+           `intersectVersionRanges`+           earlierVersion (incVersion 1 v')+  where v' = alterVersion (take 2) v++-- | Increment the nth version component (counting from 0).+incVersion :: Int -> Version -> Version+incVersion n = alterVersion (incVersion' n)+  where+    incVersion' 0 []     = [1]+    incVersion' 0 (v:_)  = [v+1]+    incVersion' m []     = replicate m 0 ++ [1]+    incVersion' m (v:vs) = v : incVersion' (m-1) vs++-- | Returns the current calendar year.+getCurrentYear :: IO Integer+getCurrentYear = do+  u <- getCurrentTime+  z <- getCurrentTimeZone+  let l = utcToLocalTime z u+      (y, _, _) = toGregorian $ localDay l+  return y++-- | From System.Directory.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]+listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do+    (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir+    rest <- concatMapM (listFilesInside test) dirs+    pure $ files ++ rest++-- | From System.Directory.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+listFilesRecursive :: FilePath -> IO [FilePath]+listFilesRecursive = listFilesInside (const $ pure True)++-- | From System.Directory.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+listContents :: FilePath -> IO [FilePath]+listContents dir = do+    xs <- getDirectoryContents dir+    pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]++-- | From Control.Monad.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b' <- b; if b' then t else f++-- | From Control.Monad.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+{-# INLINE concatMapM #-}+concatMapM op = foldr f (pure [])+    where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; pure $ x' ++ xs'++-- | From Control.Monad.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM _ [] = pure ([], [])+partitionM f (x:xs) = do+    res <- f x+    (as,bs) <- partitionM f xs+    pure ([x | res]++as, [x | not res]++bs)++-- | From Control.Monad.Extra+--   https://hackage.haskell.org/package/extra-1.7.9+notM :: Functor m => m Bool -> m Bool+notM = fmap not++safeRead :: Read a => String -> Maybe a+safeRead s+  | [(x, "")] <- reads s = Just x+  | otherwise = Nothing
src/Distribution/Client/VCS.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} module Distribution.Client.VCS (     -- * VCS driver type@@ -45,20 +47,29 @@          ( Program(programFindVersion)          , ConfiguredProgram(programVersion)          , simpleProgram, findProgramVersion-         , ProgramInvocation(..), programInvocation, runProgramInvocation+         , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput          , emptyProgramDb, requireProgram ) import Distribution.Version          ( mkVersion ) import qualified Distribution.PackageDescription as PD +import Control.Applicative+         ( liftA2 )+import Control.Exception+         ( throw, try ) import Control.Monad.Trans          ( liftIO ) import qualified Data.Char as Char+import qualified Data.List as List import qualified Data.Map  as Map import System.FilePath-         ( takeDirectory )+         ( takeDirectory, (</>) ) import System.Directory-         ( doesDirectoryExist )+         ( doesDirectoryExist+         , removeDirectoryRecursive+         )+import System.IO.Error+         ( isDoesNotExistError )   -- | A driver for a version control system, e.g. git, darcs etc.@@ -146,6 +157,9 @@       (problems@(_:_), _) -> Left problems       ([], vcss)          -> Right vcss   where+    validateSourceRepo'   :: SourceRepositoryPackage f+                          -> Either (SourceRepositoryPackage f, SourceRepoProblem)+                                    (SourceRepositoryPackage f, String, RepoType, VCS Program)     validateSourceRepo' r = either (Left . (,) r) Right                                    (validateSourceRepo r) @@ -254,9 +268,11 @@                               = "branch"                   | otherwise = "get" +        tagArgs :: [String]         tagArgs = case srpTag repo of           Nothing  -> []           Just tag -> ["-r", "tag:" ++ tag]+        verboseArg :: [String]         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]      vcsSyncRepos :: Verbosity -> ConfiguredProgram@@ -293,21 +309,65 @@     vcsCloneRepo verbosity prog repo srcuri destdir =         [ programInvocation prog cloneArgs ]       where+        cloneArgs :: [String]         cloneArgs  = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg         -- At some point the @clone@ command was introduced as an alias for         -- @get@, and @clone@ seems to be the recommended one now.+        cloneCmd :: String         cloneCmd   | programVersion prog >= Just (mkVersion [2,8])                                = "clone"                    | otherwise = "get"+        tagArgs :: [String]         tagArgs    = case srpTag repo of           Nothing  -> []           Just tag -> ["-t", tag]+        verboseArg :: [String]         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]      vcsSyncRepos :: Verbosity -> ConfiguredProgram                  -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"+    vcsSyncRepos _ _ [] = return []+    vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) =+        monitors <$ do+        vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing+        for_ secondaryRepos $ \ (repo, localDir) ->+          vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir+      where+        dirs :: [FilePath]+        dirs = primaryLocalDir : (snd <$> secondaryRepos)+        monitors :: [MonitorFilePath]+        monitors = monitorDirectoryExistence <$> dirs +    vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer =+      try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case+        Right (_:_:_:x:_)+          | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x+          , Just tag' <- srpTag+          , tag == tag' -> pure ()+        Left e | not (isDoesNotExistError e) -> throw e+        _ -> do+          removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw+          darcs (takeDirectory localDir) cloneArgs+      where+        darcs :: FilePath -> [String] -> IO ()+        darcs = darcs' runProgramInvocation++        darcsWithOutput :: FilePath -> [String] -> IO String+        darcsWithOutput = darcs' getProgramInvocationOutput++        darcs' :: (Verbosity -> ProgramInvocation -> t) -> FilePath -> [String] -> t+        darcs' f cwd args = f verbosity (programInvocation prog args)+          { progInvokeCwd = Just cwd }++        cloneArgs :: [String]+        cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg+        tagArgs :: [String]+        tagArgs    = case srpTag of+          Nothing  -> []+          Just tag -> ["-t" ++ tag]+        verboseArg :: [String]+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]+ darcsProgram :: Program darcsProgram = (simpleProgram "darcs") {     programFindVersion = findProgramVersion "--version" $ \str ->@@ -338,17 +398,18 @@     vcsCloneRepo verbosity prog repo srcuri destdir =         [ programInvocation prog cloneArgs ]         -- And if there's a tag, we have to do that in a second step:-     ++ [ (programInvocation prog (checkoutArgs tag)) {-            progInvokeCwd = Just destdir-          }-        | tag <- maybeToList (srpTag repo) ]+     ++ [ git (resetArgs tag) | tag <- maybeToList (srpTag repo) ]+     ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg)+        , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg)+        ]       where+        git args   = (programInvocation prog args) {progInvokeCwd = Just destdir}         cloneArgs  = ["clone", srcuri, destdir]                      ++ branchArgs ++ verboseArg         branchArgs = case srpBranch repo of           Just b  -> ["--branch", b]           Nothing -> []-        checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]+        resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"]         verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]      vcsSyncRepos :: Verbosity@@ -371,7 +432,20 @@         if exists           then git localDir                 ["fetch"]           else git (takeDirectory localDir) cloneArgs-        git localDir checkoutArgs+        -- Before trying to checkout other commits, all submodules must be+        -- de-initialised and the .git/modules directory must be deleted. This+        -- is needed because sometimes `git submodule sync` does not actually+        -- update the submodule source URL. Detailed description here:+        -- https://git.coop/-/snippets/85+        git localDir ["submodule", "deinit", "--force", "--all"]+        let gitModulesDir = localDir </> ".git" </> "modules"+        gitModulesExists <- doesDirectoryExist gitModulesDir+        when gitModulesExists $ removeDirectoryRecursive gitModulesDir+        git localDir resetArgs+        git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg+        git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg+        git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]+        git localDir $ ["clean", "-ffxdq"]       where         git :: FilePath -> [String] -> IO ()         git cwd args = runProgramInvocation verbosity $@@ -379,16 +453,15 @@                            progInvokeCwd = Just cwd                          } -        cloneArgs      = ["clone", "--no-checkout", loc, localDir]-                      ++ case peer of-                           Nothing           -> []-                           Just peerLocalDir -> ["--reference", peerLocalDir]-                      ++ verboseArg-                         where loc = srpLocation-        checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"-                         , checkoutTarget, "--" ]-        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)-        verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]+        cloneArgs   = ["clone", "--no-checkout", loc, localDir]+                   ++ case peer of+                        Nothing           -> []+                        Just peerLocalDir -> ["--reference", peerLocalDir]+                   ++ verboseArg+                      where loc = srpLocation+        resetArgs   = "reset" : verboseArg ++ ["--hard", resetTarget, "--" ]+        resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)+        verboseArg  = [ "--quiet" | verbosity < Verbosity.normal ]  gitProgram :: Program gitProgram = (simpleProgram "git") {@@ -445,7 +518,35 @@                  -> ConfiguredProgram                  -> [(SourceRepositoryPackage f, FilePath)]                  -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"+    vcsSyncRepos _ _ [] = return []+    vcsSyncRepos verbosity hgProg+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do+      vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir+      sequence_+        [ vcsSyncRepo verbosity hgProg repo localDir+        | (repo, localDir) <- secondaryRepos ]+      return [ monitorDirectoryExistence dir+            | dir <- (primaryLocalDir : map snd secondaryRepos) ]+    vcsSyncRepo verbosity hgProg repo localDir = do+        exists <- doesDirectoryExist localDir+        if exists+          then hg localDir ["pull"]+          else hg (takeDirectory localDir) cloneArgs+        hg localDir checkoutArgs+      where+        hg :: FilePath -> [String] -> IO ()+        hg cwd args = runProgramInvocation verbosity $+                          (programInvocation hgProg args) {+                            progInvokeCwd = Just cwd+                          }+        cloneArgs      = ["clone", "--noupdate", (srpLocation repo), localDir]+                        ++ verboseArg+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]+        checkoutArgs = [ "checkout", "--clean" ]+                      ++ tagArgs+        tagArgs = case srpTag repo of+            Just t  -> ["--rev", t]+            Nothing -> []  hgProgram :: Program hgProgram = (simpleProgram "hg") {@@ -586,8 +687,10 @@           }         | tag <- maybeToList (srpTag repo) ]       where+        cloneArgs :: [String]         cloneArgs  = ["clone", srcuri, destdir]                      ++ branchArgs+        branchArgs :: [String]         branchArgs = case srpBranch repo of           Just b  -> ["--from-branch", b]           Nothing -> []@@ -621,11 +724,13 @@                            progInvokeCwd = Just cwd                          } +        cloneArgs :: [String]         cloneArgs      = ["clone", loc, localDir]                       ++ case peer of                            Nothing           -> []                            Just peerLocalDir -> [peerLocalDir]                          where loc = srpLocation+        checkoutArgs :: [String]         checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]         checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.
+ src/Distribution/Client/Version.hs view
@@ -0,0 +1,16 @@+-- | Provides the version number of @cabal-install@.++module Distribution.Client.Version+  ( cabalInstallVersion+  ) where++import Distribution.Version++-- This value determines the `cabal-install --version` output.+-- +-- It is used in several places throughout the project, including anonymous build reports, client configuration, +-- and project planning output. Historically, this was a @Paths_*@ module, however, this conflicted with +-- program coverage information generated by HPC, and hence was moved to be a standalone value.  +--+cabalInstallVersion :: Version+cabalInstallVersion = mkVersion [3,8,1,0]
src/Distribution/Client/Win32SelfUpgrade.hs view
@@ -140,7 +140,7 @@      ++ show oldPID ++ " at path " ++ tmpPath    log $ "getting handle of parent process " ++ show oldPID-  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)+  oldPHANDLE <- Win32.openProcess Win32.sYNCHRONIZE False (fromIntegral oldPID)    log $ "synchronising with parent"   event <- openEvent syncEventName
− src/Distribution/Client/World.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.World--- Copyright   :  (c) Peter Robinson 2009--- License     :  BSD-like------ Maintainer  :  thaldyron@gmail.com--- Stability   :  provisional--- Portability :  portable------ Interface to the world-file that contains a list of explicitly--- requested packages. Meant to be imported qualified.------ A world file entry stores the package-name, package-version, and--- user flags.--- For example, the entry generated by--- # cabal install stm-io-hooks --flags="-debug"--- looks like this:--- # stm-io-hooks -any --flags="-debug"--- To rebuild/upgrade the packages in world (e.g. when updating the compiler)--- use--- # cabal install world----------------------------------------------------------------------------------module Distribution.Client.World (-    WorldPkgInfo(..),-    insert,-    delete,-    getContents,-  ) where--import Prelude (sequence)-import Distribution.Client.Compat.Prelude hiding (getContents)--import Distribution.Types.Dependency-import Distribution.Types.Flag-         ( FlagAssignment, unFlagAssignment-         , unFlagName, parsecFlagAssignmentNonEmpty )-import Distribution.Simple.Utils-         ( die', info, chattyTry, writeFileAtomic )-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--import Data.List-         ( unionBy, deleteFirstsBy )-import System.IO.Error-         ( isDoesNotExistError )-import qualified Data.ByteString.Lazy.Char8 as B---data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment-  deriving (Show,Eq, Generic)---- | Adds packages to the world file; creates the file if it doesn't--- exist yet. Version constraints and flag assignments for a package are--- updated if already present. IO errors are non-fatal.-insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()-insert = modifyWorld $ unionBy equalUDep---- | Removes packages from the world file.--- Note: Currently unused as there is no mechanism in Cabal (yet) to--- handle uninstalls. IO errors are non-fatal.-delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()-delete = modifyWorld $ flip (deleteFirstsBy equalUDep)---- | WorldPkgInfo values are considered equal if they refer to--- the same package, i.e., we don't care about differing versions or flags.-equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool-equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _)-          (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2---- | Modifies the world file by applying an update-function ('unionBy'--- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of--- packages. IO errors are considered non-fatal.-modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]-                -> [WorldPkgInfo])-                        -- ^ Function that defines how-                        -- the list of user packages are merged with-                        -- existing world packages.-            -> Verbosity-            -> FilePath               -- ^ Location of the world file-            -> [WorldPkgInfo] -- ^ list of user supplied packages-            -> IO ()-modifyWorld _ _         _     []   = return ()-modifyWorld f verbosity world pkgs =-  chattyTry "Error while updating world-file. " $ do-    pkgsOldWorld <- getContents verbosity world-    -- Filter out packages that are not in the world file:-    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld-    -- 'Dependency' is not an Ord instance, so we need to check for-    -- equivalence the awkward way:-    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&-            all (`elem` pkgsNewWorld) pkgsOldWorld)-      then do-        info verbosity "Updating world file..."-        writeFileAtomic world . B.pack $ unlines-            [ (prettyShow pkg) | pkg <- pkgsNewWorld]-      else-        info verbosity "World file is already up to date."----- | Returns the content of the world file as a list-getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]-getContents verbosity world = do-  content <- safelyReadFile world-  let result = map simpleParsec (lines $ B.unpack content)-  case sequence result of-    Nothing -> die' verbosity "Could not parse world file."-    Just xs -> return xs-  where-  safelyReadFile :: FilePath -> IO B.ByteString-  safelyReadFile file = B.readFile file `catchIO` handler-    where-      handler e | isDoesNotExistError e = return B.empty-                | otherwise             = ioError e---instance Pretty WorldPkgInfo where-  pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)-    where-      dispFlags [] = Disp.empty-      dispFlags fs = Disp.text "--flags="-                  <<>> Disp.doubleQuotes (flagAssToDoc fs)-      flagAssToDoc = foldr (\(fname,val) flagAssDoc ->-                             (if not val then Disp.char '-'-                                         else Disp.char '+')-                             <<>> Disp.text (unFlagName fname)-                             Disp.<+> flagAssDoc)-                           Disp.empty--instance Parsec WorldPkgInfo where-  parsec = do-      dep <- parsec-      P.spaces-      flagAss <- P.option mempty parseFlagAssignment-      return $ WorldPkgInfo dep flagAss-    where-      parseFlagAssignment :: CabalParsing m => m FlagAssignment-      parseFlagAssignment = do-          _ <- P.string "--flags="-          inDoubleQuotes parsecFlagAssignmentNonEmpty-        where-          inDoubleQuotes = P.between (P.char '"') (P.char '"')
src/Distribution/Deprecated/ParseUtils.hs view
@@ -105,12 +105,20 @@         ParseOk ws x >>= f = case f x of                                ParseFailed err -> ParseFailed err                                ParseOk ws' x' -> ParseOk (ws'++ws) x'- #if !(MIN_VERSION_base(4,9,0))         fail = parseResultFail #elif !(MIN_VERSION_base(4,13,0))         fail = Fail.fail #endif++instance Foldable ParseResult where+  foldMap _ (ParseFailed _ ) = mempty+  foldMap f (ParseOk _ x) = f x++instance Traversable ParseResult where+  traverse _ (ParseFailed err) = pure (ParseFailed err)+  traverse f (ParseOk ws x) = ParseOk ws <$> f x+  instance Fail.MonadFail ParseResult where         fail = parseResultFail
+ tests/IntegrationTests2.hs view
@@ -0,0 +1,1981 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++-- For the handy instance IsString PackageIdentifier+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.DistDirLayout+import Distribution.Client.ProjectConfig+import Distribution.Client.Config (getCabalDir)+import Distribution.Client.HttpUtils+import Distribution.Client.TargetSelector hiding (DirActions(..))+import qualified Distribution.Client.TargetSelector as TS (DirActions(..))+import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.ProjectBuilding+import Distribution.Client.ProjectOrchestration+         ( resolveTargets, distinctTargetComponents )+import Distribution.Client.TargetProblem+         ( TargetProblem', TargetProblem (..) )+import Distribution.Client.Types+         ( PackageLocation(..), UnresolvedSourcePackage+         , PackageSpecifier(..) )+import Distribution.Client.Targets+         ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Solver.Types.SourcePackage as SP+import Distribution.Solver.Types.ConstraintSource+         ( ConstraintSource(ConstraintSourceUnknown) )+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(PackagePropertySource) )++import qualified Distribution.Client.CmdBuild   as CmdBuild+import qualified Distribution.Client.CmdRepl    as CmdRepl+import qualified Distribution.Client.CmdRun     as CmdRun+import qualified Distribution.Client.CmdTest    as CmdTest+import qualified Distribution.Client.CmdBench   as CmdBench+import qualified Distribution.Client.CmdHaddock as CmdHaddock+import qualified Distribution.Client.CmdListBin as CmdListBin++import Distribution.Package+import Distribution.PackageDescription+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags)+import Distribution.Client.Setup (globalCommand)+import Distribution.Simple.Compiler+import Distribution.Simple.Command+import qualified Distribution.Simple.Flag as Flag+import Distribution.System+import Distribution.Version+import Distribution.ModuleName (ModuleName)+import Distribution.Text+import Distribution.Utils.Path++import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad+import Control.Concurrent (threadDelay)+import Control.Exception hiding (assert)+import System.FilePath+import System.Directory+import System.IO (hPutStrLn, stderr)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options+import Data.Tagged (Tagged(..))++import qualified Data.ByteString as BS+import Distribution.Client.GlobalFlags (GlobalFlags, globalNix)+import Distribution.Simple.Flag (Flag (Flag, NoFlag))+import Data.Maybe (fromJust)++#if !MIN_VERSION_directory(1,2,7)+removePathForcibly :: FilePath -> IO ()+removePathForcibly = removeDirectoryRecursive+#endif++main :: IO ()+main =+  defaultMainWithIngredients+    (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions])+    (withProjectConfig $ \config ->+      testGroup "Integration tests (internal)"+                (tests config))+++tests :: ProjectConfig -> [TestTree]+tests config =+    --TODO: tests for:+    -- * normal success+    -- * dry-run tests with changes+  [ testGroup "Discovery and planning" $+    [ testCase "find root"      testFindProjectRoot+    , testCase "find root fail" testExceptionFindProjectRoot+    , testCase "no package"    (testExceptionInFindingPackage config)+    , testCase "no package2"   (testExceptionInFindingPackage2 config)+    , testCase "proj conf1"    (testExceptionInProjectConfig config)+    ]+  , testGroup "Target selectors" $+    [ testCaseSteps "valid"              testTargetSelectors+    , testCase      "bad syntax"         testTargetSelectorBadSyntax+    , testCaseSteps "ambiguous syntax"   testTargetSelectorAmbiguous+    , testCase      "no current pkg"     testTargetSelectorNoCurrentPackage+    , testCase      "no targets"         testTargetSelectorNoTargets+    , testCase      "project empty"      testTargetSelectorProjectEmpty+    , testCase      "canonicalized path" testTargetSelectorCanonicalizedPath+    , testCase      "problems (common)"  (testTargetProblemsCommon config)+    , testCaseSteps "problems (build)"   (testTargetProblemsBuild config)+    , testCaseSteps "problems (repl)"    (testTargetProblemsRepl config)+    , testCaseSteps "problems (run)"     (testTargetProblemsRun config)+    , testCaseSteps "problems (list-bin)" (testTargetProblemsListBin config)+    , testCaseSteps "problems (test)"    (testTargetProblemsTest config)+    , testCaseSteps "problems (bench)"   (testTargetProblemsBench config)+    , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config)+    ]+  , testGroup "Exceptions during building (local inplace)" $+    [ testCase "configure"   (testExceptionInConfigureStep config)+    , testCase "build"       (testExceptionInBuildStep config)+--    , testCase "register"   testExceptionInRegisterStep+    ]+    --TODO: need to repeat for packages for the store+    --TODO: need to check we can build sub-libs, foreign libs and exes+    -- components for non-local packages / packages in the store.++  , testGroup "Successful builds" $+    [ testCaseSteps "Setup script styles" (testSetupScriptStyles config)+    , testCase      "keep-going"          (testBuildKeepGoing config)+#ifndef mingw32_HOST_OS+    -- disabled because https://github.com/haskell/cabal/issues/6272+    , testCase      "local tarball"       (testBuildLocalTarball config)+#endif+    ]++  , testGroup "Regression tests" $+    [ testCase "issue #3324" (testRegressionIssue3324 config)+    , testCase "program options scope all" (testProgramOptionsAll config)+    , testCase "program options scope local" (testProgramOptionsLocal config)+    , testCase "program options scope specific" (testProgramOptionsSpecific config)+    ]+  , testGroup "Flag tests" $+    [+      testCase "Test Nix Flag" testNixFlags,+      testCase "Test Ignore Project Flag" testIgnoreProjectFlag+    ]+  ]++testFindProjectRoot :: Assertion+testFindProjectRoot = do+    Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir)+                                                              (Just testfile)+    file @?= testfile+  where+    testdir  = basedir </> "exception" </> "no-pkg2"+    testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN"+++testExceptionFindProjectRoot :: Assertion+testExceptionFindProjectRoot = do+    Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing+    cwd <- getCurrentDirectory+    dir @?= cwd </> testdir+  where+    testdir = basedir </> "exception" </> "no-pkg2"+++testTargetSelectors :: (String -> IO ()) -> Assertion+testTargetSelectors reportSubCase = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)+                                                       localPackages+                                                       Nothing++    reportSubCase "cwd"+    do Right ts <- readTargetSelectors' []+       ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing]++    reportSubCase "all"+    do Right ts <- readTargetSelectors'+                     ["all", ":all"]+       ts @?= replicate 2 (TargetAllPackages Nothing)++    reportSubCase "filter"+    do Right ts <- readTargetSelectors'+                     [ "libs",  ":cwd:libs"+                     , "flibs", ":cwd:flibs"+                     , "exes",  ":cwd:exes"+                     , "tests", ":cwd:tests"+                     , "benchmarks", ":cwd:benchmarks"]+       zipWithM_ (@?=) ts+         [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind)+         | kind <- concatMap (replicate 2) [LibKind .. ]+         ]++    reportSubCase "all:filter"+    do Right ts <- readTargetSelectors'+                     [ "all:libs",  ":all:libs"+                     , "all:flibs", ":all:flibs"+                     , "all:exes",  ":all:exes"+                     , "all:tests", ":all:tests"+                     , "all:benchmarks", ":all:benchmarks"]+       zipWithM_ (@?=) ts+         [ TargetAllPackages (Just kind)+         | kind <- concatMap (replicate 2) [LibKind .. ]+         ]++    reportSubCase "pkg"+    do Right ts <- readTargetSelectors'+                     [       ":pkg:p", ".",  "./",   "p.cabal"+                     , "q",  ":pkg:q", "q/", "./q/", "q/q.cabal"]+       ts @?= replicate 4 (mkTargetPackage "p-0.1")+           ++ replicate 5 (mkTargetPackage "q-0.1")++    reportSubCase "pkg:filter"+    do Right ts <- readTargetSelectors'+                     [ "p:libs",  ".:libs",  ":pkg:p:libs"+                     , "p:flibs", ".:flibs", ":pkg:p:flibs"+                     , "p:exes",  ".:exes",  ":pkg:p:exes"+                     , "p:tests", ".:tests",  ":pkg:p:tests"+                     , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks"+                     , "q:libs",  "q/:libs", ":pkg:q:libs"+                     , "q:flibs", "q/:flibs", ":pkg:q:flibs"+                     , "q:exes",  "q/:exes", ":pkg:q:exes"+                     , "q:tests", "q/:tests", ":pkg:q:tests"+                     , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"]+       zipWithM_ (@?=) ts $+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind)+         | kind <- concatMap (replicate 3) [LibKind .. ]+         ] +++         [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind)+         | kind <- concatMap (replicate 3) [LibKind .. ]+         ]++    reportSubCase "component"+    do Right ts <- readTargetSelectors'+                     [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p"+                     ,      "lib:q", "q:lib:q", ":pkg:q:lib:q" ]+       ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent)+           ++ replicate 3 (TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent)++    reportSubCase "module"+    do Right ts <- readTargetSelectors'+                     [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P"+                     , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ"+                     , "pexe:PMain" -- p:P or q:QQ would be ambiguous here+                     , "qexe:QMain" -- package p vs component p+                     ]+       ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) (ModuleTarget "P"))+           ++ replicate 4 (TargetComponent "q-0.1" (CLibName LMainLibName) (ModuleTarget "QQ"))+           ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain")+              , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain")+              ]++    reportSubCase "file"+    do Right ts <- readTargetSelectors'+                     [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc",+                                 ":pkg:p:lib:p:file:P.y"+                     , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc",+                                  ":pkg:q:lib:q:file:QQ.y"+                     , "q/Q.hs", "q:Q.lhs", "lib:q:Q.hsc", "q:q:Q.hsc",+                                  ":pkg:q:lib:q:file:Q.y"+                     , "app/Main.hs", "p:app/Main.hs", "exe:ppexe:app/Main.hs", "p:ppexe:app/Main.hs",+                                  ":pkg:p:exe:ppexe:file:app/Main.hs"+                     ]+       ts @?= replicate 5 (TargetComponent "p-0.1" (CLibName LMainLibName) (FileTarget "P"))+           ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "QQ"))+           ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "Q"))+           ++ replicate 5 (TargetComponent "p-0.1" (CExeName "ppexe") (FileTarget ("app" </> "Main.hs")))+       -- Note there's a bit of an inconsistency here: for the single-part+       -- syntax the target has to point to a file that exists, whereas for+       -- all the other forms we don't require that.++    cleanProject testdir+  where+    testdir = "targets/simple"+    config  = mempty+++testTargetSelectorBadSyntax :: Assertion+testTargetSelectorBadSyntax = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let targets = [ "foo bar",  " foo"+                  , "foo:", "foo::bar"+                  , "foo: ", "foo: :bar"+                  , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ]+    Left errs <- readTargetSelectors localPackages Nothing targets+    zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets)+    cleanProject testdir+  where+    testdir = "targets/empty"+    config  = mempty+++testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion+testTargetSelectorAmbiguous reportSubCase = do++    -- 'all' is ambiguous with packages and cwd components+    reportSubCase "ambiguous: all vs pkg"+    assertAmbiguous "all"+      [mkTargetPackage "all", mkTargetAllPackages]+      [mkpkg "all" []]++    reportSubCase "ambiguous: all vs cwd component"+    assertAmbiguous "all"+      [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages]+      [mkpkg "other" [mkexe "all"]]++    -- but 'all' is not ambiguous with non-cwd components, modules or files+    reportSubCase "unambiguous: all vs non-cwd comp, mod, file"+    assertUnambiguous "All"+      mkTargetAllPackages+      [ mkpkgAt "foo" [mkexe "All"] "foo"+      , mkpkg   "bar" [ mkexe "bar" `withModules` ["All"]+                      , mkexe "baz" `withCFiles` ["All"] ]+      ]++    -- filters 'libs', 'exes' etc are ambiguous with packages and+    -- local components+    reportSubCase "ambiguous: cwd-pkg filter vs pkg"+    assertAmbiguous "libs"+      [ mkTargetPackage "libs"+      , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ]+      [mkpkg "libs" []]++    reportSubCase "ambiguous: filter vs cwd component"+    assertAmbiguous "exes"+      [ mkTargetComponent "other" (CExeName "exes")+      , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ]+      [mkpkg "other" [mkexe "exes"]]++    -- but filters are not ambiguous with non-cwd components, modules or files+    reportSubCase "unambiguous: filter vs non-cwd comp, mod, file"+    assertUnambiguous "Libs"+      (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind))+      [ mkpkgAt "foo" [mkexe "Libs"] "foo"+      , mkpkg   "bar" [ mkexe "bar" `withModules` ["Libs"]+                      , mkexe "baz" `withCFiles` ["Libs"] ]+      ]++    -- local components shadow packages and other components+    reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp"+    assertUnambiguous "foo"+      (mkTargetComponent "other" (CExeName "foo"))+      [ mkpkg   "other"  [mkexe "foo"]+      , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo+      , mkpkg "foo" [] ]                        -- shadows package foo++    -- local components shadow modules and files+    reportSubCase "unambiguous: cwd comp vs module, file"+    assertUnambiguous "Foo"+      (mkTargetComponent "bar" (CExeName "Foo"))+      [ mkpkg "bar" [mkexe "Foo"]+      , mkpkg "other" [ mkexe "other"  `withModules` ["Foo"]+                      , mkexe "other2" `withCFiles`  ["Foo"] ]+      ]++    -- packages shadow non-local components+    reportSubCase "unambiguous: pkg vs non-cwd comp"+    assertUnambiguous "foo"+      (mkTargetPackage "foo")+      [ mkpkg "foo" []+      , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo+      ]++    -- packages shadow modules and files+    reportSubCase "unambiguous: pkg vs module, file"+    assertUnambiguous "Foo"+      (mkTargetPackage "Foo")+      [ mkpkgAt "Foo" [] "foo"+      , mkpkg "other" [ mkexe "other"  `withModules` ["Foo"]+                      , mkexe "other2" `withCFiles`  ["Foo"] ]+      ]++    -- File target is ambiguous, part of multiple components+    reportSubCase "ambiguous: file in multiple comps"+    assertAmbiguous "Bar.hs"+      [ mkTargetFile "foo" (CExeName "bar")  "Bar"+      , mkTargetFile "foo" (CExeName "bar2") "Bar"+      ]+      [ mkpkg "foo" [ mkexe "bar"  `withModules` ["Bar"]+                    , mkexe "bar2" `withModules` ["Bar"] ]+      ]+    reportSubCase "ambiguous: file in multiple comps with path"+    assertAmbiguous ("src" </> "Bar.hs")+      [ mkTargetFile "foo" (CExeName "bar")  ("src" </> "Bar")+      , mkTargetFile "foo" (CExeName "bar2") ("src" </> "Bar")+      ]+      [ mkpkg "foo" [ mkexe "bar"  `withModules` ["Bar"] `withHsSrcDirs` ["src"]+                    , mkexe "bar2" `withModules` ["Bar"] `withHsSrcDirs` ["src"] ]+      ]++    -- non-exact case packages and components are ambiguous+    reportSubCase "ambiguous: non-exact-case pkg names"+    assertAmbiguous "Foo"+      [ mkTargetPackage "foo", mkTargetPackage "FOO" ]+      [ mkpkg "foo" [], mkpkg "FOO" [] ]+    reportSubCase "ambiguous: non-exact-case comp names"+    assertAmbiguous "Foo"+      [ mkTargetComponent "bar" (CExeName "foo")+      , mkTargetComponent "bar" (CExeName "FOO") ]+      [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ]++    -- exact-case Module or File over non-exact case package or component+    reportSubCase "unambiguous: module vs non-exact-case pkg, comp"+    assertUnambiguous "Baz"+      (mkTargetModule "other" (CExeName "other") "Baz")+      [ mkpkg "baz" [mkexe "BAZ"]+      , mkpkg "other" [ mkexe "other"  `withModules` ["Baz"] ]+      ]+    reportSubCase "unambiguous: file vs non-exact-case pkg, comp"+    assertUnambiguous "Baz"+      (mkTargetFile "other" (CExeName "other") "Baz")+      [ mkpkg "baz" [mkexe "BAZ"]+      , mkpkg "other" [ mkexe "other"  `withCFiles` ["Baz"] ]+      ]+  where+    assertAmbiguous :: String+                    -> [TargetSelector]+                    -> [SourcePackage (PackageLocation a)]+                    -> Assertion+    assertAmbiguous str tss pkgs = do+      res <- readTargetSelectorsWith+               fakeDirActions+               (map SpecificSourcePackage pkgs)+               Nothing+               [str]+      case res of+        Left [TargetSelectorAmbiguous _ tss'] ->+          sort (map snd tss') @?= sort tss+        _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], "+                          ++ "got " ++ show res++    assertUnambiguous :: String+                      -> TargetSelector+                      -> [SourcePackage (PackageLocation a)]+                      -> Assertion+    assertUnambiguous str ts pkgs = do+      res <- readTargetSelectorsWith+               fakeDirActions+               (map SpecificSourcePackage pkgs)+               Nothing+               [str]+      case res of+        Right [ts'] -> ts' @?= ts+        _ -> assertFailure $ "expected Right [Target...], "+                          ++ "got " ++ show res++    fakeDirActions = TS.DirActions {+      TS.doesFileExist       = \_p -> return True,+      TS.doesDirectoryExist  = \_p -> return True,+      TS.canonicalizePath    = \p -> return ("/" </> p), -- FilePath.Unix.</> ?+      TS.getCurrentDirectory = return "/"+    }++    mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a)+    mkpkg pkgidstr exes = mkpkgAt pkgidstr exes ""++    mkpkgAt :: String -> [Executable] -> FilePath+            -> SourcePackage (PackageLocation a)+    mkpkgAt pkgidstr exes loc =+      SourcePackage {+        srcpkgPackageId = pkgid,+        srcpkgSource = LocalUnpackedPackage loc,+        srcpkgDescrOverride  = Nothing,+        srcpkgDescription = GenericPackageDescription {+          packageDescription = emptyPackageDescription { package = pkgid },+          gpdScannedVersion  = Nothing,+          genPackageFlags    = [],+          condLibrary        = Nothing,+          condSubLibraries   = [],+          condForeignLibs    = [],+          condExecutables    = [ ( exeName exe, CondNode exe [] [] )+                               | exe <- exes ],+          condTestSuites     = [],+          condBenchmarks     = []+        }+      }+      where+        pkgid = fromMaybe (error $ "failed to parse " ++ pkgidstr) $ simpleParse pkgidstr++    mkexe :: String -> Executable+    mkexe name = mempty { exeName = fromString name }++    withModules :: Executable -> [String] -> Executable+    withModules exe mods =+      exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } }++    withCFiles :: Executable -> [FilePath] -> Executable+    withCFiles exe files =+      exe { buildInfo = (buildInfo exe) { cSources = files } }++    withHsSrcDirs :: Executable -> [FilePath] -> Executable+    withHsSrcDirs exe srcDirs =+      exe { buildInfo = (buildInfo exe) { hsSourceDirs = map unsafeMakeSymbolicPath srcDirs }}+++mkTargetPackage :: PackageId -> TargetSelector+mkTargetPackage pkgid =+    TargetPackage TargetExplicitNamed [pkgid] Nothing++mkTargetComponent :: PackageId -> ComponentName -> TargetSelector+mkTargetComponent pkgid cname =+    TargetComponent pkgid cname WholeComponent++mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector+mkTargetModule pkgid cname mname =+    TargetComponent pkgid cname (ModuleTarget mname)++mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector+mkTargetFile pkgid cname fname =+    TargetComponent pkgid cname (FileTarget fname)++mkTargetAllPackages :: TargetSelector+mkTargetAllPackages = TargetAllPackages Nothing++instance IsString PackageIdentifier where+    fromString pkgidstr = pkgid+      where pkgid = fromMaybe (error $ "fromString @PackageIdentifier " ++ show pkgidstr) $ simpleParse pkgidstr+++testTargetSelectorNoCurrentPackage :: Assertion+testTargetSelectorNoCurrentPackage = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)+                                                       localPackages+                                                       Nothing+        targets = [ "libs",  ":cwd:libs"+                  , "flibs", ":cwd:flibs"+                  , "exes",  ":cwd:exes"+                  , "tests", ":cwd:tests"+                  , "benchmarks", ":cwd:benchmarks"]+    Left errs <- readTargetSelectors' targets+    zipWithM_ (@?=) errs+      [ TargetSelectorNoCurrentPackage ts+      | target <- targets+      , let ts = fromMaybe (error $ "failed to parse target string " ++ target) $ parseTargetString target+      ]+    cleanProject testdir+  where+    testdir = "targets/complex"+    config  = mempty+++testTargetSelectorNoTargets :: Assertion+testTargetSelectorNoTargets = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    Left errs <- readTargetSelectors localPackages Nothing []+    errs @?= [TargetSelectorNoTargetsInCwd True]+    cleanProject testdir+  where+    testdir = "targets/complex"+    config  = mempty+++testTargetSelectorProjectEmpty :: Assertion+testTargetSelectorProjectEmpty = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    Left errs <- readTargetSelectors localPackages Nothing []+    errs @?= [TargetSelectorNoTargetsInProject]+    cleanProject testdir+  where+    testdir = "targets/empty"+    config  = mempty+++-- | Ensure we don't miss primary package and produce+-- TargetSelectorNoTargetsInCwd error due to symlink or+-- drive capitalisation mismatch when no targets are given+testTargetSelectorCanonicalizedPath :: Assertion+testTargetSelectorCanonicalizedPath = do+  (_, _, _, localPackages, _) <- configureProject testdir config+  cwd <- getCurrentDirectory+  let virtcwd = cwd </> basedir </> symlink+  -- Check that the symlink is there before running test as on Windows+  -- some versions/configurations of git won't pull down/create the symlink+  canRunTest <- doesDirectoryExist virtcwd+  when canRunTest (do+      let dirActions' = (dirActions symlink) { TS.getCurrentDirectory = return virtcwd }+      Right ts <- readTargetSelectorsWith dirActions' localPackages Nothing []+      ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing])+  cleanProject testdir+  where+    testdir = "targets/simple"+    symlink = "targets/symbolic-link-to-simple"+    config = mempty+++testTargetProblemsCommon :: ProjectConfig -> Assertion+testTargetProblemsCommon config0 = do+    (_,elaboratedPlan,_) <- planProject testdir config++    let pkgIdMap :: Map.Map PackageName PackageId+        pkgIdMap = Map.fromList+                     [ (packageName p, packageId p)+                     | p <- InstallPlan.toList elaboratedPlan ]++        cases :: [( TargetSelector -> TargetProblem'+                  , TargetSelector+                  )]+        cases =+          [ -- Cannot resolve packages outside of the project+            ( \_ -> TargetProblemNoSuchPackage "foobar"+            , mkTargetPackage "foobar" )++            -- We cannot currently build components like testsuites or+            -- benchmarks from packages that are not local to the project+          , ( \_ -> TargetComponentNotProjectLocal+                      (pkgIdMap Map.! "filepath") (CTestName "filepath-tests")+                      WholeComponent+            , mkTargetComponent (pkgIdMap Map.! "filepath")+                                (CTestName "filepath-tests") )++            -- Components can be explicitly @buildable: False@+          , ( \_ -> TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent+            , mkTargetComponent "q-0.1" (CExeName "buildable-false") )++            -- Testsuites and benchmarks can be disabled by the solver if it+            -- cannot satisfy deps+          , ( \_ -> TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent+            , mkTargetComponent "q-0.1" (CTestName "solver-disabled") )++            -- Testsuites and benchmarks can be disabled explicitly by the+            -- user via config+          , ( \_ -> TargetOptionalStanzaDisabledByUser+                      "q-0.1" (CBenchName "user-disabled") WholeComponent+            , mkTargetComponent "q-0.1" (CBenchName "user-disabled") )++            -- An unknown package. The target selector resolution should only+            -- produce known packages, so this should not happen with the+            -- output from 'readTargetSelectors'.+          , ( \_ -> TargetProblemNoSuchPackage "foobar"+            , mkTargetPackage "foobar" )++            -- An unknown component of a known package. The target selector+            -- resolution should only produce known packages, so this should+            -- not happen with the output from 'readTargetSelectors'.+          , ( \_ -> TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such")+            , mkTargetComponent "q-0.1" (CExeName "no-such") )+          ]+    assertTargetProblems+      elaboratedPlan+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      cases+  where+    testdir = "targets/complex"+    config  = config0 {+      projectConfigLocalPackages = (projectConfigLocalPackages config0) {+        packageConfigBenchmarks = toFlag False+      }+    , projectConfigShared = (projectConfigShared config0) {+        projectConfigConstraints =+          [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource+           , ConstraintSourceUnknown )]+      }+    }+++testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsBuild config reportSubCase = do++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "all-disabled"+    assertProjectTargetProblems+      "targets/all-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigBenchmarks = toFlag False+        }+      }+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CExeName "buildable-false")+                                 TargetNotBuildable True+               , AvailableTarget "p-0.1" (CLibName LMainLibName)+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "enabled component kinds"+    -- When we explicitly enable all the component kinds then selecting the+    -- whole package selects those component kinds too+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config {+           projectConfigLocalPackages = (projectConfigLocalPackages config) {+             packageConfigTests      = toFlag True,+             packageConfigBenchmarks = toFlag True+           }+         }+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         [ mkTargetPackage "p-0.1" ]+         [ ("p-0.1-inplace",             (CLibName LMainLibName))+         , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+         , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+         , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+         , ("p-0.1-inplace-libp",        CFLibName  "libp")+         ]++    reportSubCase "disabled component kinds"+    -- When we explicitly disable all the component kinds then selecting the+    -- whole package only selects the library, foreign lib and exes+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config {+           projectConfigLocalPackages = (projectConfigLocalPackages config) {+             packageConfigTests      = toFlag False,+             packageConfigBenchmarks = toFlag False+           }+         }+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         [ mkTargetPackage "p-0.1" ]+         [ ("p-0.1-inplace",        (CLibName LMainLibName))+         , ("p-0.1-inplace-an-exe", CExeName  "an-exe")+         , ("p-0.1-inplace-libp",   CFLibName "libp")+         ]++    reportSubCase "requested component kinds"+    -- When we selecting the package with an explicit filter then we get those+    -- components even though we did not explicitly enable tests/benchmarks+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)+         , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)+         ]+         [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+         , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+         ]+++testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsRepl config reportSubCase = do++    reportSubCase "multiple-libs"+    assertProjectTargetProblems+      "targets/multiple-libs" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip CmdRepl.matchesMultipleProblem+               [ AvailableTarget "p-0.1" (CLibName LMainLibName)+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "q-0.1" (CLibName LMainLibName)+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetAllPackages )+      ]++    reportSubCase "multiple-exes"+    assertProjectTargetProblems+      "targets/multiple-exes" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip CmdRepl.matchesMultipleProblem+               [ AvailableTarget "p-0.1" (CExeName "p2")+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "p-0.1" (CExeName "p1")+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "multiple-tests"+    assertProjectTargetProblems+      "targets/multiple-tests" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip CmdRepl.matchesMultipleProblem+               [ AvailableTarget "p-0.1" (CTestName "p2")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               , AvailableTarget "p-0.1" (CTestName "p1")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               ]+        , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) )+      ]++    reportSubCase "multiple targets"+    do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         [ mkTargetComponent "p-0.1" (CExeName "p1")+         , mkTargetComponent "p-0.1" (CExeName "p2")+         ]+         [ ("p-0.1-inplace-p1", CExeName "p1")+         , ("p-0.1-inplace-p2", CExeName "p2")+         ]++    reportSubCase "libs-disabled"+    assertProjectTargetProblems+      "targets/libs-disabled" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CLibName LMainLibName) TargetNotBuildable True ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "exes-disabled"+    assertProjectTargetProblems+      "targets/exes-disabled" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "test-only"+    assertProjectTargetProblems+      "targets/test-only" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "pexe")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "requested component kinds"+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config+       -- by default we only get the lib+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ]+         [ ("p-0.1-inplace", (CLibName LMainLibName)) ]+       -- When we select the package with an explicit filter then we get those+       -- components even though we did not explicitly enable tests/benchmarks+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ]+         [ ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite") ]+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ]+         [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ]++testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsListBin config reportSubCase = do+    reportSubCase "one-of-each"+    do (_,elaboratedPlan,_) <- planProject "targets/one-of-each" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdListBin.selectPackageTargets+         CmdListBin.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing+         ]+         [ ("p-0.1-inplace-p1",      CExeName   "p1")+         ]++    reportSubCase "multiple-exes"+    assertProjectTargetProblems+      "targets/multiple-exes" config+      CmdListBin.selectPackageTargets+      CmdListBin.selectComponentTarget+      [ ( flip CmdListBin.matchesMultipleProblem+               [ AvailableTarget "p-0.1" (CExeName "p2")+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "p-0.1" (CExeName "p1")+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "multiple targets"+    do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdListBin.selectPackageTargets+         CmdListBin.selectComponentTarget+         [ mkTargetComponent "p-0.1" (CExeName "p1")+         , mkTargetComponent "p-0.1" (CExeName "p2")+         ]+         [ ("p-0.1-inplace-p1", CExeName "p1")+         , ("p-0.1-inplace-p2", CExeName "p2")+         ]++    reportSubCase "exes-disabled"+    assertProjectTargetProblems+      "targets/exes-disabled" config+      CmdListBin.selectPackageTargets+      CmdListBin.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdListBin.selectPackageTargets+      CmdListBin.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "lib-only"+    assertProjectTargetProblems+      "targets/lib-only" config+      CmdListBin.selectPackageTargets+      CmdListBin.selectComponentTarget+      [ (CmdListBin.noComponentsProblem, mkTargetPackage "p-0.1" )+      ]++testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsRun config reportSubCase = do+    reportSubCase "one-of-each"+    do (_,elaboratedPlan,_) <- planProject "targets/one-of-each" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRun.selectPackageTargets+         CmdRun.selectComponentTarget+         [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing+         ]+         [ ("p-0.1-inplace-p1",      CExeName   "p1")+         ]++    reportSubCase "multiple-exes"+    assertProjectTargetProblems+      "targets/multiple-exes" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      [ ( flip CmdRun.matchesMultipleProblem+               [ AvailableTarget "p-0.1" (CExeName "p2")+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "p-0.1" (CExeName "p1")+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "multiple targets"+    do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRun.selectPackageTargets+         CmdRun.selectComponentTarget+         [ mkTargetComponent "p-0.1" (CExeName "p1")+         , mkTargetComponent "p-0.1" (CExeName "p2")+         ]+         [ ("p-0.1-inplace-p1", CExeName "p1")+         , ("p-0.1-inplace-p2", CExeName "p2")+         ]++    reportSubCase "exes-disabled"+    assertProjectTargetProblems+      "targets/exes-disabled" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "lib-only"+    assertProjectTargetProblems+      "targets/lib-only" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      [ (CmdRun.noExesProblem, mkTargetPackage "p-0.1" )+      ]+++testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsTest config reportSubCase = do++    reportSubCase "disabled by config"+    assertProjectTargetProblems+      "targets/tests-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigTests = toFlag False+        }+      }+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledByUser True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "disabled by solver & buildable false"+    assertProjectTargetProblems+      "targets/tests-disabled"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "user-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               ]+        , mkTargetPackage "p-0.1" )++      , ( flip TargetProblemNoneEnabled+               [ AvailableTarget "q-0.1" (CTestName "buildable-false")+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "q-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "no tests"+    assertProjectTargetProblems+      "targets/simple"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      [ ( CmdTest.noTestsProblem, mkTargetPackage "p-0.1" )+      , ( CmdTest.noTestsProblem, mkTargetPackage "q-0.1" )+      ]++    reportSubCase "not a test"+    assertProjectTargetProblems+      "targets/variety"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget $+      [ ( const (CmdTest.notTestProblem+                  "p-0.1" (CLibName LMainLibName))+        , mkTargetComponent "p-0.1" (CLibName LMainLibName) )++      , ( const (CmdTest.notTestProblem+                  "p-0.1" (CExeName "an-exe"))+        , mkTargetComponent "p-0.1" (CExeName "an-exe") )++      , ( const (CmdTest.notTestProblem+                  "p-0.1" (CFLibName "libp"))+        , mkTargetComponent "p-0.1" (CFLibName "libp") )++      , ( const (CmdTest.notTestProblem+                  "p-0.1" (CBenchName "a-benchmark"))+        , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") )+      ] +++      [ ( const (CmdTest.isSubComponentProblem+                          "p-0.1" cname (ModuleTarget modname))+        , mkTargetModule "p-0.1" cname modname )+      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")+                            , (CBenchName "a-benchmark", "BenchModule")+                            , (CExeName   "an-exe",      "ExeModule")+                            , ((CLibName LMainLibName),                 "P")+                            ]+      ] +++      [ ( const (CmdTest.isSubComponentProblem+                          "p-0.1" cname (FileTarget fname))+        , mkTargetFile "p-0.1" cname fname)+      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")+                          , (CBenchName "a-benchmark", "Bench.hs")+                          , (CExeName   "an-exe",      "Main.hs")+                          ]+      ]+++testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsBench config reportSubCase = do++    reportSubCase "disabled by config"+    assertProjectTargetProblems+      "targets/benchmarks-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigBenchmarks = toFlag False+        }+      }+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CBenchName "solver-disabled")+                                 TargetDisabledByUser True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "disabled by solver & buildable false"+    assertProjectTargetProblems+      "targets/benchmarks-disabled"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CBenchName "solver-disabled")+                                 TargetDisabledBySolver True+               ]+        , mkTargetPackage "p-0.1" )++      , ( flip TargetProblemNoneEnabled+               [ AvailableTarget "q-0.1" (CBenchName "buildable-false")+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "q-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "no benchmarks"+    assertProjectTargetProblems+      "targets/simple"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      [ ( CmdBench.noBenchmarksProblem, mkTargetPackage "p-0.1" )+      , ( CmdBench.noBenchmarksProblem, mkTargetPackage "q-0.1" )+      ]++    reportSubCase "not a benchmark"+    assertProjectTargetProblems+      "targets/variety"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget $+      [ ( const (CmdBench.componentNotBenchmarkProblem+                  "p-0.1" (CLibName LMainLibName))+        , mkTargetComponent "p-0.1" (CLibName LMainLibName) )++      , ( const (CmdBench.componentNotBenchmarkProblem+                  "p-0.1" (CExeName "an-exe"))+        , mkTargetComponent "p-0.1" (CExeName "an-exe") )++      , ( const (CmdBench.componentNotBenchmarkProblem+                  "p-0.1" (CFLibName "libp"))+        , mkTargetComponent "p-0.1" (CFLibName "libp") )++      , ( const (CmdBench.componentNotBenchmarkProblem+                  "p-0.1" (CTestName "a-testsuite"))+        , mkTargetComponent "p-0.1" (CTestName "a-testsuite") )+      ] +++      [ ( const (CmdBench.isSubComponentProblem+                          "p-0.1" cname (ModuleTarget modname))+        , mkTargetModule "p-0.1" cname modname )+      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")+                            , (CBenchName "a-benchmark", "BenchModule")+                            , (CExeName   "an-exe",      "ExeModule")+                            , ((CLibName LMainLibName),                 "P")+                            ]+      ] +++      [ ( const (CmdBench.isSubComponentProblem+                          "p-0.1" cname (FileTarget fname))+        , mkTargetFile "p-0.1" cname fname)+      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")+                          , (CBenchName "a-benchmark", "Bench.hs")+                          , (CExeName   "an-exe",      "Main.hs")+                          ]+      ]+++testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsHaddock config reportSubCase = do++    reportSubCase "all-disabled"+    assertProjectTargetProblems+      "targets/all-disabled"+      config+      (let haddockFlags = mkHaddockFlags False True True False+        in CmdHaddock.selectPackageTargets haddockFlags)+      CmdHaddock.selectComponentTarget+      [ ( flip TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CExeName "buildable-false")+                                 TargetNotBuildable True+               , AvailableTarget "p-0.1" (CLibName LMainLibName)+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      (let haddockFlags = mkHaddockFlags False False False False+        in CmdHaddock.selectPackageTargets haddockFlags)+      CmdHaddock.selectComponentTarget+      [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "enabled component kinds"+    -- When we explicitly enable all the component kinds then selecting the+    -- whole package selects those component kinds too+    (_,elaboratedPlan,_) <- planProject "targets/variety" config+    let haddockFlags = mkHaddockFlags True True True True+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          [ mkTargetPackage "p-0.1" ]+          [ ("p-0.1-inplace",             (CLibName LMainLibName))+          , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+          , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+          , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+          , ("p-0.1-inplace-libp",        CFLibName  "libp")+          ]++    reportSubCase "disabled component kinds"+    -- When we explicitly disable all the component kinds then selecting the+    -- whole package only selects the library+    let haddockFlags = mkHaddockFlags False False False False+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          [ mkTargetPackage "p-0.1" ]+          [ ("p-0.1-inplace", (CLibName LMainLibName)) ]++    reportSubCase "requested component kinds"+    -- When we selecting the package with an explicit filter then it does not+    -- matter if the config was to disable all the component kinds+    let haddockFlags = mkHaddockFlags False False False False+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)+          , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)+          ]+          [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+          , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+          , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+          , ("p-0.1-inplace-libp",        CFLibName  "libp")+          ]+  where+    mkHaddockFlags flib exe test bench =+      defaultHaddockFlags {+        haddockForeignLibs = toFlag flib,+        haddockExecutables = toFlag exe,+        haddockTestSuites  = toFlag test,+        haddockBenchmarks  = toFlag bench+      }++assertProjectDistinctTargets+  :: forall err. (Eq err, Show err) =>+     ElaboratedInstallPlan+  -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k])+  -> (forall k. SubComponentTarget ->  AvailableTarget k  -> Either (TargetProblem err)  k )+  -> [TargetSelector]+  -> [(UnitId, ComponentName)]+  -> Assertion+assertProjectDistinctTargets elaboratedPlan+                             selectPackageTargets+                             selectComponentTarget+                             targetSelectors+                             expectedTargets+  | Right targets <- results+  = distinctTargetComponents targets @?= Set.fromList expectedTargets++  | otherwise+  = assertFailure $ "assertProjectDistinctTargets: expected "+                 ++ "(Right targets) but got " ++ show results+  where+    results = resolveTargets+                selectPackageTargets+                selectComponentTarget+                elaboratedPlan+                Nothing+                targetSelectors+++assertProjectTargetProblems+  :: forall err. (Eq err, Show err) =>+     FilePath -> ProjectConfig+  -> (forall k. TargetSelector+             -> [AvailableTarget k]+             -> Either (TargetProblem err) [k])+  -> (forall k. SubComponentTarget+             -> AvailableTarget k+             -> Either (TargetProblem err) k )+  -> [(TargetSelector -> TargetProblem err, TargetSelector)]+  -> Assertion+assertProjectTargetProblems testdir config+                            selectPackageTargets+                            selectComponentTarget+                            cases = do+    (_,elaboratedPlan,_) <- planProject testdir config+    assertTargetProblems+      elaboratedPlan+      selectPackageTargets+      selectComponentTarget+      cases+++assertTargetProblems+  :: forall err. (Eq err, Show err) =>+     ElaboratedInstallPlan+  -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k])+  -> (forall k. SubComponentTarget ->  AvailableTarget k  -> Either (TargetProblem err)  k )+  -> [(TargetSelector -> TargetProblem err, TargetSelector)]+  -> Assertion+assertTargetProblems elaboratedPlan selectPackageTargets selectComponentTarget =+    mapM_ (uncurry assertTargetProblem)+  where+    assertTargetProblem expected targetSelector =+      let res = resolveTargets selectPackageTargets selectComponentTarget+                               elaboratedPlan Nothing+                               [targetSelector] in+      case res of+        Left [problem] ->+          problem @?= expected targetSelector++        unexpected ->+          assertFailure $ "expected resolveTargets result: (Left [problem]) "+                       ++ "but got: " ++ show unexpected+++testExceptionInFindingPackage :: ProjectConfig -> Assertion+testExceptionInFindingPackage config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadLocGlobEmptyMatch "./*.cabal"] -> return ()+      _ -> assertFailure "expected BadLocGlobEmptyMatch"+    cleanProject testdir+  where+    testdir = "exception/no-pkg"+++testExceptionInFindingPackage2 :: ProjectConfig -> Assertion+testExceptionInFindingPackage2 config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return ()+      _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs+    cleanProject testdir+  where+    testdir = "exception/no-pkg2"+++testExceptionInProjectConfig :: ProjectConfig -> Assertion+testExceptionInProjectConfig config = do+    BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $+      void $ planProject testdir config+    case ps of+      [(pn,"ghc")] | "foo" == pn -> return ()+      _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got "+                        ++ show ps+    cleanProject testdir+  where+    testdir = "exception/bad-config"+++testExceptionInConfigureStep :: ProjectConfig -> Assertion+testExceptionInConfigureStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    case buildFailureReason failure of+      ConfigureFailed _ -> return ()+      _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure+    cleanProject testdir+  where+    testdir = "exception/configure"+    pkgidA1 = PackageIdentifier "a" (mkVersion [1])+++testExceptionInBuildStep :: ProjectConfig -> Assertion+testExceptionInBuildStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    expectBuildFailed failure+  where+    testdir = "exception/build"+    pkgidA1 = PackageIdentifier "a" (mkVersion [1])++testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion+testSetupScriptStyles config reportSubCase = do++  reportSubCase (show SetupCustomExplicitDeps)++  plan0@(_,_,sharedConfig) <- planProject testdir1 config++  let isOSX (Platform _ OSX) = True+      isOSX _ = False+  -- Skip the Custom tests when the shipped Cabal library is buggy+  unless (isOSX (pkgConfigPlatform sharedConfig)+       && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do++    (plan1, res1) <- executePlan plan0+    pkg1          <- expectPackageInstalled plan1 res1 pkgidA+    elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps+    hasDefaultSetupDeps pkg1 @?= Just False+    marker1 <- readFile (basedir </> testdir1 </> "marker")+    marker1 @?= "ok"+    removeFile (basedir </> testdir1 </> "marker")++    -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later+    when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8,2]) $ do+      reportSubCase (show SetupCustomImplicitDeps)+      (plan2, res2) <- executePlan =<< planProject testdir2 config+      pkg2          <- expectPackageInstalled plan2 res2 pkgidA+      elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps+      hasDefaultSetupDeps pkg2 @?= Just True+      marker2 <- readFile (basedir </> testdir2 </> "marker")+      marker2 @?= "ok"+      removeFile (basedir </> testdir2 </> "marker")++    reportSubCase (show SetupNonCustomInternalLib)+    (plan3, res3) <- executePlan =<< planProject testdir3 config+    pkg3          <- expectPackageInstalled plan3 res3 pkgidA+    elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib+{-+    --TODO: the SetupNonCustomExternalLib case is hard to test since it+    -- requires a version of Cabal that's later than the one we're testing+    -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0+    -- and a corresponding Cabal package that we can use to try and build a+    -- default Setup.hs.+    reportSubCase (show SetupNonCustomExternalLib)+    (plan4, res4) <- executePlan =<< planProject testdir4 config+    pkg4          <- expectPackageInstalled plan4 res4 pkgidA+    pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib+-}+  where+    testdir1 = "build/setup-custom1"+    testdir2 = "build/setup-custom2"+    testdir3 = "build/setup-simple"+    pkgidA   = PackageIdentifier "a" (mkVersion [0,1])+    -- The solver fills in default setup deps explicitly, but marks them as such+    hasDefaultSetupDeps = fmap defaultSetupDepends+                        . setupBuildInfo . elabPkgDescription++-- | Test the behaviour with and without @--keep-going@+--+testBuildKeepGoing :: ProjectConfig -> Assertion+testBuildKeepGoing config = do+    -- P is expected to fail, Q does not depend on P but without+    -- parallel build and without keep-going then we don't build Q yet.+    (plan1, res1) <- executePlan =<< planProject testdir (config `mappend` keepGoing False)+    (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1"+    expectBuildFailed failure1+    _ <- expectPackageConfigured plan1 res1 "q-0.1"++    -- With keep-going then we should go on to successfully build Q+    (plan2, res2) <- executePlan+                 =<< planProject testdir (config `mappend` keepGoing True)+    (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1"+    expectBuildFailed failure2+    _ <- expectPackageInstalled plan2 res2 "q-0.1"+    return ()+  where+    testdir = "build/keep-going"+    keepGoing kg =+      mempty {+        projectConfigBuildOnly = mempty {+          projectConfigKeepGoing = toFlag kg+        }+      }++-- | Test we can successfully build packages from local tarball files.+--+testBuildLocalTarball :: ProjectConfig -> Assertion+testBuildLocalTarball config = do+    -- P is a tarball package, Q is a local dir package that depends on it.+    (plan, res) <- executePlan =<< planProject testdir config+    _ <- expectPackageInstalled plan res "p-0.1"+    _ <- expectPackageInstalled plan res "q-0.1"+    return ()+  where+    testdir = "build/local-tarball"++-- | See <https://github.com/haskell/cabal/issues/3324>+--+-- This test just doesn't seem to work on Windows,+-- due filesystem woes.+--+testRegressionIssue3324 :: ProjectConfig -> Assertion+testRegressionIssue3324 config = when (buildOS /= Windows) $ do+    -- expected failure first time due to missing dep+    (plan1, res1) <- executePlan =<< planProject testdir config+    (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1"+    expectBuildFailed failure++    -- add the missing dep, now it should work+    let qcabal  = basedir </> testdir </> "q" </> "q.cabal"+    withFileFinallyRestore qcabal $ do+      tryFewTimes $ BS.appendFile qcabal ("  build-depends: p\n")+      (plan2, res2) <- executePlan =<< planProject testdir config+      _ <- expectPackageInstalled plan2 res2 "p-0.1"+      _ <- expectPackageInstalled plan2 res2 "q-0.1"+      return ()+  where+    testdir = "regression/3324"++-- | Test global program options are propagated correctly+-- from ProjectConfig to ElaboratedInstallPlan+testProgramOptionsAll :: ProjectConfig -> Assertion+testProgramOptionsAll config0 = do+    -- P is a tarball package, Q is a local dir package that depends on it.+    (_, elaboratedPlan, _) <- planProject testdir config+    let packages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan++    assertEqual "q"+                (Just [ghcFlag])+                (getProgArgs packages "q")+    assertEqual "p"+                (Just [ghcFlag])+                (getProgArgs packages "p")+  where+    testdir = "regression/program-options"+    programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])])+    ghcFlag = "-fno-full-laziness"++    -- Insert flag into global config+    config = config0 {+      projectConfigAllPackages = (projectConfigAllPackages config0) {+        packageConfigProgramArgs = programArgs+      }+    }++-- | Test local program options are propagated correctly+-- from ProjectConfig to ElaboratedInstallPlan+testProgramOptionsLocal :: ProjectConfig -> Assertion+testProgramOptionsLocal config0 = do+    (_, elaboratedPlan, _) <- planProject testdir config+    let localPackages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan++    assertEqual "q"+                (Just [ghcFlag])+                (getProgArgs localPackages "q")+    assertEqual "p"+                Nothing+                (getProgArgs localPackages "p")+  where+    testdir = "regression/program-options"+    programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])])+    ghcFlag = "-fno-full-laziness"++    -- Insert flag into local config+    config = config0 {+      projectConfigLocalPackages = (projectConfigLocalPackages config0) {+        packageConfigProgramArgs = programArgs+      }+    }++-- | Test package specific program options are propagated correctly+-- from ProjectConfig to ElaboratedInstallPlan+testProgramOptionsSpecific :: ProjectConfig -> Assertion+testProgramOptionsSpecific config0 = do+    (_, elaboratedPlan, _) <- planProject testdir config+    let packages = filterConfiguredPackages $ InstallPlan.toList elaboratedPlan++    assertEqual "q"+                (Nothing)+                (getProgArgs packages "q")+    assertEqual "p"+                (Just [ghcFlag])+                (getProgArgs packages "p")+  where+    testdir = "regression/program-options"+    programArgs = MapMappend (Map.fromList [("ghc", [ghcFlag])])+    ghcFlag = "-fno-full-laziness"++    -- Insert flag into package "p" config+    config = config0 {+        projectConfigSpecificPackage = MapMappend (Map.fromList [(mkPackageName "p", configArgs)])+    }+    configArgs = mempty {+        packageConfigProgramArgs = programArgs+    }++filterConfiguredPackages :: [ElaboratedPlanPackage] -> [ElaboratedConfiguredPackage]+filterConfiguredPackages [] = []+filterConfiguredPackages (InstallPlan.PreExisting _    : pkgs) = filterConfiguredPackages pkgs+filterConfiguredPackages (InstallPlan.Installed   elab : pkgs) = elab : filterConfiguredPackages pkgs+filterConfiguredPackages (InstallPlan.Configured  elab : pkgs) = elab : filterConfiguredPackages pkgs++getProgArgs :: [ElaboratedConfiguredPackage] -> String -> Maybe [String]+getProgArgs [] _ = Nothing+getProgArgs (elab : pkgs) name+    | pkgName (elabPkgSourceId elab) == mkPackageName name+        = Map.lookup "ghc" (elabProgramArgs elab)+    | otherwise+        = getProgArgs pkgs name++---------------------------------+-- Test utils to plan and build+--++basedir :: FilePath+basedir = "tests" </> "IntegrationTests2"++dirActions :: FilePath -> TS.DirActions IO+dirActions testdir =+    defaultDirActions {+      TS.doesFileExist       = \p ->+        TS.doesFileExist defaultDirActions (virtcwd </> p),++      TS.doesDirectoryExist  = \p ->+        TS.doesDirectoryExist defaultDirActions (virtcwd </> p),++      TS.canonicalizePath    = \p ->+        TS.canonicalizePath defaultDirActions (virtcwd </> p),++      TS.getCurrentDirectory =+        TS.canonicalizePath defaultDirActions virtcwd+    }+  where+    virtcwd = basedir </> testdir++type ProjDetails = (DistDirLayout,+                    CabalDirLayout,+                    ProjectConfig,+                    [PackageSpecifier UnresolvedSourcePackage],+                    BuildTimeSettings)++configureProject :: FilePath -> ProjectConfig -> IO ProjDetails+configureProject testdir cliConfig = do+    cabalDir <- getCabalDir+    let cabalDirLayout = defaultCabalDirLayout cabalDir++    projectRootDir <- canonicalizePath (basedir </> testdir)+    isexplict      <- doesFileExist (projectRootDir </> "cabal.project")+    let projectRoot+          | isexplict = ProjectRootExplicit projectRootDir+                                           (projectRootDir </> "cabal.project")+          | otherwise = ProjectRootImplicit projectRootDir+        distDirLayout = defaultDistDirLayout projectRoot Nothing++    -- Clear state between test runs. The state remains if the previous run+    -- ended in an exception (as we leave the files to help with debugging).+    cleanProject testdir++    httpTransport <- configureTransport verbosity [] Nothing++    (projectConfig, localPackages) <-+      rebuildProjectConfig verbosity+                           httpTransport+                           distDirLayout+                           cliConfig++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return (distDirLayout,+            cabalDirLayout,+            projectConfig,+            localPackages,+            buildSettings)++type PlanDetails = (ProjDetails,+                    ElaboratedInstallPlan,+                    ElaboratedSharedConfig)++planProject :: FilePath -> ProjectConfig -> IO PlanDetails+planProject testdir cliConfig = do++    projDetails@(+       distDirLayout,+       cabalDirLayout,+       projectConfig,+       localPackages,+       _buildSettings) <- configureProject testdir cliConfig++    (elaboratedPlan, _, elaboratedShared, _, _) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages++    return (projDetails,+            elaboratedPlan,+            elaboratedShared)++executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes)+executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings),+             elaboratedPlan,+             elaboratedShared) = do++    let targets :: Map.Map UnitId [ComponentTarget]+        targets =+          Map.fromList+            [ (unitid, [ComponentTarget cname WholeComponent])+            | ts <- Map.elems (availableTargets elaboratedPlan)+            , AvailableTarget {+                availableTargetStatus = TargetBuildable (unitid, cname) _+              } <- ts+            ]+        elaboratedPlan' = pruneInstallPlanToTargets+                            TargetActionBuild targets+                            elaboratedPlan++    pkgsBuildStatus <-+      rebuildTargetsDryRun distDirLayout elaboratedShared+                           elaboratedPlan'++    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                             pkgsBuildStatus elaboratedPlan'++    buildOutcomes <-+      rebuildTargets verbosity+                     distDirLayout+                     (cabalStoreDirLayout cabalDirLayout)+                     elaboratedPlan''+                     elaboratedShared+                     pkgsBuildStatus+                     -- Avoid trying to use act-as-setup mode:+                     buildSettings { buildSettingNumJobs = 1 }++    return (elaboratedPlan'', buildOutcomes)++cleanProject :: FilePath -> IO ()+cleanProject testdir = do+    alreadyExists <- doesDirectoryExist distDir+    when alreadyExists $ removePathForcibly distDir+  where+    projectRoot    = ProjectRootImplicit (basedir </> testdir)+    distDirLayout  = defaultDistDirLayout projectRoot Nothing+    distDir        = distDirectory distDirLayout+++verbosity :: Verbosity+verbosity = minBound --normal --verbose --maxBound --minBound++++-------------------------------------------+-- Tasty integration to adjust the config+--++withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree+withProjectConfig testtree =+    askOption $ \ghcPath ->+      testtree (mkProjectConfig ghcPath)++mkProjectConfig :: GhcPath -> ProjectConfig+mkProjectConfig (GhcPath ghcPath) =+    mempty {+      projectConfigShared = mempty {+        projectConfigHcPath = maybeToFlag ghcPath+      },+     projectConfigBuildOnly = mempty {+       projectConfigNumJobs = toFlag (Just 1)+     }+    }+  where+    maybeToFlag = maybe mempty toFlag+++data GhcPath = GhcPath (Maybe FilePath)+  deriving Typeable++instance IsOption GhcPath where+  defaultValue = GhcPath Nothing+  optionName   = Tagged "with-ghc"+  optionHelp   = Tagged "The ghc compiler to use"+  parseValue   = Just . GhcPath . Just++projectConfigOptionDescriptions :: [OptionDescription]+projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)]+++---------------------------------------+-- HUint style utils for this context+--++expectException :: Exception e => String -> IO a -> IO e+expectException expected action = do+    res <- try action+    case res of+      Left  e -> return e+      Right _ -> throwIO $ HUnitFailure Nothing $ "expected an exception " ++ expected++expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                         -> IO InstalledPackageInfo+expectPackagePreExisting plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.PreExisting pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult++expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                        -> IO ElaboratedConfiguredPackage+expectPackageConfigured plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult++expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                       -> IO ElaboratedConfiguredPackage+expectPackageInstalled plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Right _result)) -- result isn't used by any test+                       -> return pkg+      -- package can be installed in the global .store!+      -- (when installing from tarball!)+      (InstallPlan.Installed pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult++expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                    -> IO (ElaboratedConfiguredPackage, BuildFailure)+expectPackageFailed plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Left failure))+                       -> return (pkg, failure)+      (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult++unexpectedBuildResult :: String -> ElaboratedPlanPackage+                      -> Maybe (Either BuildFailure BuildResult) -> IO a+unexpectedBuildResult expected planpkg buildResult =+    throwIO $ HUnitFailure Nothing $+         "expected to find " ++ display (packageId planpkg) ++ " in the "+      ++ expected ++ " state, but it is actually in the " ++ actual ++ " state."+  where+    actual = case (buildResult, planpkg) of+      (Nothing, InstallPlan.PreExisting{})       -> "PreExisting"+      (Nothing, InstallPlan.Configured{})        -> "Configured"+      (Just (Right _), InstallPlan.Configured{}) -> "Installed"+      (Just (Left  _), InstallPlan.Configured{}) -> "Failed"+      (Nothing, InstallPlan.Installed{})         -> "Installed globally"+      _                                          -> "Impossible! " ++ show buildResult ++ show planpkg++expectPlanPackage :: ElaboratedInstallPlan -> PackageId+                  -> IO ElaboratedPlanPackage+expectPlanPackage plan pkgid =+    case [ pkg+         | pkg <- InstallPlan.toList plan+         , packageId pkg == pkgid ] of+      [pkg] -> return pkg+      []    -> throwIO $ HUnitFailure Nothing $+                   "expected to find " ++ display pkgid+                ++ " in the install plan but it's not there"+      _     -> throwIO $ HUnitFailure Nothing $+                   "expected to find only one instance of " ++ display pkgid+                ++ " in the install plan but there's several"++expectBuildFailed :: BuildFailure -> IO ()+expectBuildFailed (BuildFailure _ (BuildFailed _)) = return ()+expectBuildFailed (BuildFailure _ reason) =+    assertFailure $ "expected BuildFailed, got " ++ show reason++---------------------------------------+-- Other utils+--++-- | Allow altering a file during a test, but then restore it afterwards+--+-- We read into the memory, as filesystems are tricky. (especially Windows)+--+withFileFinallyRestore :: FilePath -> IO a -> IO a+withFileFinallyRestore file action = do+    originalContents <- BS.readFile file+    action `finally` handle onIOError (tryFewTimes $ BS.writeFile file originalContents)+  where+    onIOError :: IOException -> IO ()+    onIOError e = putStrLn $ "WARNING: Cannot restore " ++ file ++ "; " ++ show e++-- Hopefully works around some Windows file-locking things.+-- Use with care:+--+-- Try action 4 times, with small sleep in between,+-- retrying if it fails for 'IOException' reason.+--+tryFewTimes :: forall a. IO a -> IO a+tryFewTimes action = go (3 :: Int) where+    go :: Int -> IO a+    go !n | n <= 0    = action+          | otherwise = action `catch` onIOError n++    onIOError :: Int -> IOException -> IO a+    onIOError n e = do+        hPutStrLn stderr $ "Trying " ++ show n ++ " after " ++ show e+        threadDelay 10000+        go (n - 1)++testNixFlags :: Assertion+testNixFlags = do+  let gc = globalCommand []+  -- changing from the v1 to v2 build command does not change whether the "--enable-nix" flag+  -- sets the globalNix param of the GlobalFlags type to True even though the v2 command doesn't use it+  let nixEnabledFlags = getFlags gc . commandParseArgs gc True $ ["--enable-nix", "build"]+  let nixDisabledFlags = getFlags gc . commandParseArgs gc True $ ["--disable-nix", "build"]+  let nixDefaultFlags = getFlags gc . commandParseArgs gc True $ ["build"]+  True @=? isJust nixDefaultFlags+  True @=? isJust nixEnabledFlags+  True @=? isJust nixDisabledFlags+  Just True @=? (fromFlag . globalNix . fromJust $ nixEnabledFlags)+  Just False @=? (fromFlag . globalNix . fromJust $ nixDisabledFlags)+  Nothing @=? (fromFlag . globalNix . fromJust $ nixDefaultFlags)+  where+    fromFlag :: Flag Bool -> Maybe Bool+    fromFlag (Flag x) = Just x+    fromFlag NoFlag = Nothing+    getFlags :: CommandUI GlobalFlags -> CommandParse (GlobalFlags -> GlobalFlags, [String]) -> Maybe GlobalFlags+    getFlags cui (CommandReadyToGo (mkflags, _)) = Just . mkflags . commandDefaultFlags $ cui+    getFlags _ _ = Nothing++testIgnoreProjectFlag :: Assertion+testIgnoreProjectFlag = do+  -- Coverage flag should be false globally by default (~/.cabal folder)+  (_, _, prjConfigGlobal, _, _) <- configureProject testdir ignoreSetConfig+  let globalCoverageFlag = packageConfigCoverage . projectConfigLocalPackages $ prjConfigGlobal+  False @=? Flag.fromFlagOrDefault False globalCoverageFlag+  -- It is set to true in the cabal.project file+  (_, _, prjConfigLocal, _, _) <- configureProject testdir emptyConfig+  let localCoverageFlag = packageConfigCoverage . projectConfigLocalPackages $ prjConfigLocal+  True @=? Flag.fromFlagOrDefault False localCoverageFlag+  where+    testdir = "build/ignore-project"+    emptyConfig = mempty+    ignoreSetConfig :: ProjectConfig+    ignoreSetConfig = mempty { projectConfigShared = mempty { projectConfigIgnoreProject = Flag True } }
+ tests/LongTests.hs view
@@ -0,0 +1,46 @@+module Main (main) where+++import Test.Tasty++import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Compat.Time++import qualified UnitTests.Distribution.Client.FileMonitor+import qualified UnitTests.Distribution.Client.VCS+import qualified UnitTests.Distribution.Solver.Modular.QuickCheck+import qualified UnitTests.Distribution.Client.Described+import UnitTests.Options+++main :: IO ()+main = do+  (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay+  let toMillis :: Int -> Double+      toMillis x = fromIntegral x / 1000.0+  notice normal $ "File modification time resolution calibration completed, "+    ++ "maximum delay observed: "+    ++ (show . toMillis $ mtimeChange ) ++ " ms. "+    ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')+    ++ " for test runs."+  defaultMainWithIngredients+         (includingOptions extraOptions : defaultIngredients)+         (tests mtimeChange')+++tests :: Int -> TestTree+tests mtimeChangeCalibrated =+  askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->+    let mtimeChange = if mtimeChangeProvided /= 0+                      then mtimeChangeProvided+                      else mtimeChangeCalibrated+    in testGroup "Long-running tests"+      [ testGroup "Solver QuickCheck"+        UnitTests.Distribution.Solver.Modular.QuickCheck.tests+      , testGroup "UnitTests.Distribution.Client.VCS" $+        UnitTests.Distribution.Client.VCS.tests mtimeChange+      , testGroup "UnitTests.Distribution.Client.FileMonitor" $+        UnitTests.Distribution.Client.FileMonitor.tests mtimeChange+      , UnitTests.Distribution.Client.Described.tests+      ]
+ tests/MemoryUsageTests.hs view
@@ -0,0 +1,15 @@+module Main where++import Test.Tasty++import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage++tests :: TestTree+tests =+  testGroup "Memory Usage"+  [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage"+        UnitTests.Distribution.Solver.Modular.MemoryUsage.tests+  ]++main :: IO ()+main = defaultMain tests
+ tests/UnitTests.hs view
@@ -0,0 +1,77 @@+module Main (main) where+++import Test.Tasty++import qualified UnitTests.Distribution.Client.BuildReport+import qualified UnitTests.Distribution.Client.Configure+import qualified UnitTests.Distribution.Client.FetchUtils+import qualified UnitTests.Distribution.Client.Get+import qualified UnitTests.Distribution.Client.Glob+import qualified UnitTests.Distribution.Client.GZipUtils+import qualified UnitTests.Distribution.Client.IndexUtils+import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp+import qualified UnitTests.Distribution.Client.Init+import qualified UnitTests.Distribution.Client.InstallPlan+import qualified UnitTests.Distribution.Client.JobControl+import qualified UnitTests.Distribution.Client.ProjectConfig+import qualified UnitTests.Distribution.Client.ProjectPlanning+import qualified UnitTests.Distribution.Client.Store+import qualified UnitTests.Distribution.Client.Tar+import qualified UnitTests.Distribution.Client.Targets+import qualified UnitTests.Distribution.Client.UserConfig+import qualified UnitTests.Distribution.Solver.Modular.Builder+import qualified UnitTests.Distribution.Solver.Modular.RetryLog+import qualified UnitTests.Distribution.Solver.Modular.Solver+import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ+import qualified UnitTests.Distribution.Solver.Types.OptionalStanza++main :: IO ()+main = do+  initTests <- UnitTests.Distribution.Client.Init.tests+  defaultMain $ testGroup "Unit Tests"+    [ testGroup "UnitTests.Distribution.Client.BuildReport"+        UnitTests.Distribution.Client.BuildReport.tests+    , testGroup "UnitTests.Distribution.Client.Configure"+        UnitTests.Distribution.Client.Configure.tests+    , testGroup "UnitTests.Distribution.Client.FetchUtils"+        UnitTests.Distribution.Client.FetchUtils.tests+    , testGroup "UnitTests.Distribution.Client.Get"+        UnitTests.Distribution.Client.Get.tests+    , testGroup "UnitTests.Distribution.Client.Glob"+        UnitTests.Distribution.Client.Glob.tests+    , testGroup "Distribution.Client.GZipUtils"+        UnitTests.Distribution.Client.GZipUtils.tests+    , testGroup "UnitTests.Distribution.Client.IndexUtils"+        UnitTests.Distribution.Client.IndexUtils.tests+    , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"+        UnitTests.Distribution.Client.IndexUtils.Timestamp.tests+    , testGroup "Distribution.Client.Init"+        initTests+    , testGroup "UnitTests.Distribution.Client.InstallPlan"+        UnitTests.Distribution.Client.InstallPlan.tests+    , testGroup "UnitTests.Distribution.Client.JobControl"+        UnitTests.Distribution.Client.JobControl.tests+    , testGroup "UnitTests.Distribution.Client.ProjectConfig"+        UnitTests.Distribution.Client.ProjectConfig.tests+    , testGroup "UnitTests.Distribution.Client.ProjectPlanning"+        UnitTests.Distribution.Client.ProjectPlanning.tests+    , testGroup "Distribution.Client.Store"+        UnitTests.Distribution.Client.Store.tests+    , testGroup "Distribution.Client.Tar"+        UnitTests.Distribution.Client.Tar.tests+    , testGroup "Distribution.Client.Targets"+        UnitTests.Distribution.Client.Targets.tests+    , testGroup "UnitTests.Distribution.Client.UserConfig"+        UnitTests.Distribution.Client.UserConfig.tests+    , testGroup "UnitTests.Distribution.Solver.Modular.Builder"+        UnitTests.Distribution.Solver.Modular.Builder.tests+    , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"+        UnitTests.Distribution.Solver.Modular.RetryLog.tests+    , testGroup "UnitTests.Distribution.Solver.Modular.Solver"+        UnitTests.Distribution.Solver.Modular.Solver.tests+    , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"+        UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests+    , testGroup "UnitTests.Distribution.Solver.Types.OptionalStanza"+        UnitTests.Distribution.Solver.Types.OptionalStanza.tests+    ]
+ tests/UnitTests/Distribution/Client/ArbitraryInstances.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE TypeOperators    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module UnitTests.Distribution.Client.ArbitraryInstances (+    adjustSize,+    shortListOf,+    shortListOf1,+    arbitraryFlag,+    ShortToken(..),+    arbitraryShortToken,+    NonMEmpty(..),+    NoShrink(..),+    -- * Shrinker+    Shrinker,+    runShrinker,+    shrinker,+    shrinkerPP,+    shrinkerAla,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Data.Char (isLetter)+import Data.List ((\\))++import Distribution.Simple.Setup+import Distribution.Types.Flag   (mkFlagAssignment)++import Distribution.Client.BuildReports.Types            (BuildReport, InstallOutcome, Outcome, ReportLevel (..))+import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)+import Distribution.Client.Glob                          (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..))+import Distribution.Client.IndexUtils.ActiveRepos        (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))+import Distribution.Client.IndexUtils.IndexState         (RepoIndexState (..), TotalIndexState, makeTotalIndexState)+import Distribution.Client.IndexUtils.Timestamp          (Timestamp, epochTimeToTimestamp)+import Distribution.Client.Targets+import Distribution.Client.Types                         (RepoName (..), WriteGhcEnvironmentFilesPolicy)+import Distribution.Client.Types.AllowNewer+import Distribution.Client.Types.OverwritePolicy         (OverwritePolicy)+import Distribution.Solver.Types.OptionalStanza          (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate)+import Distribution.Solver.Types.PackageConstraint       (PackageProperty (..))++import Data.Coerce                      (Coercible, coerce)+import Network.URI                      (URI (..), URIAuth (..), isUnreserved)+import Test.QuickCheck+import Test.QuickCheck.GenericArbitrary+import Test.QuickCheck.Instances.Cabal ()++-- note: there are plenty of instances defined in ProjectConfig test file.+-- they should be moved here or into Cabal-quickcheck++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++data Shrinker a = Shrinker a [a]++instance Functor Shrinker where+    fmap f (Shrinker x xs) = Shrinker (f x) (map f xs)++instance Applicative Shrinker where+    pure x = Shrinker x []++    Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs)++runShrinker :: Shrinker a -> [a]+runShrinker (Shrinker _ xs) = xs++shrinker :: Arbitrary a => a -> Shrinker a+shrinker x = Shrinker x (shrink x)++shrinkerAla :: (Coercible a b, Arbitrary b) => (a -> b) -> a -> Shrinker a+shrinkerAla pack = shrinkerPP pack coerce++-- | shrinker with pre and post functions.+shrinkerPP :: Arbitrary b => (a -> b) -> (b -> a) -> a -> Shrinker a+shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x)))++-------------------------------------------------------------------------------+-- Non-Cabal instances+-------------------------------------------------------------------------------++instance Arbitrary URI where+    arbitrary =+      URI <$> elements ["file:", "http:", "https:"]+          <*> (Just <$> arbitrary)+          <*> (('/':) <$> arbitraryURIToken)+          <*> (('?':) <$> arbitraryURIToken)+          <*> pure ""++instance Arbitrary URIAuth where+    arbitrary =+      URIAuth <$> pure ""   -- no password as this does not roundtrip+              <*> arbitraryURIToken+              <*> arbitraryURIPort++arbitraryURIToken :: Gen String+arbitraryURIToken =+    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))++arbitraryURIPort :: Gen String+arbitraryURIPort =+    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]++-------------------------------------------------------------------------------+-- cabal-install (and Cabal) types+-------------------------------------------------------------------------------++shrinkBoundedEnum :: (Eq a, Enum a, Bounded a) => a -> [a]+shrinkBoundedEnum x+    | x == minBound = []+    | otherwise     = [pred x]++adjustSize :: (Int -> Int) -> Gen a -> Gen a+adjustSize adjust gen = sized (\n -> resize (adjust n) gen)++shortListOf :: Int -> Gen a -> Gen [a]+shortListOf bound gen =+    sized $ \n -> do+      k <- choose (0, (n `div` 2) `min` bound)+      vectorOf k gen++shortListOf1 :: Int -> Gen a -> Gen [a]+shortListOf1 bound gen =+    sized $ \n -> do+      k <- choose (1, 1 `max` ((n `div` 2) `min` bound))+      vectorOf k gen++newtype ShortToken = ShortToken { getShortToken :: String }+  deriving Show++instance Arbitrary ShortToken where+  arbitrary =+    ShortToken <$>+      (shortListOf1 5 (choose ('#', '~'))+       `suchThat` (all (`notElem` "{}"))+       `suchThat` (not . ("[]" `isPrefixOf`)))+    --TODO: [code cleanup] need to replace parseHaskellString impl to stop+    -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.+    -- Workaround, don't generate [] as this does not round trip.++  shrink (ShortToken cs) =+    [ ShortToken cs' | cs' <- shrink cs, not (null cs') ]++arbitraryShortToken :: Gen String+arbitraryShortToken = getShortToken <$> arbitrary++newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }+  deriving (Eq, Ord, Show)++instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where+  arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))+  shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]++newtype NoShrink a = NoShrink { getNoShrink :: a }+  deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (NoShrink a) where+    arbitrary = NoShrink <$> arbitrary+    shrink _  = []++instance Arbitrary Timestamp where+    -- note: no negative timestamps+    --+    -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0+    -- >>> 3093527980800s+    --+    arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary++instance Arbitrary RepoIndexState where+    arbitrary = frequency [ (1, pure IndexStateHead)+                          , (50, IndexStateTime <$> arbitrary)+                          ]++instance Arbitrary TotalIndexState where+    arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary++instance Arbitrary WriteGhcEnvironmentFilesPolicy where+    arbitrary = arbitraryBoundedEnum++arbitraryFlag :: Gen a -> Gen (Flag a)+arbitraryFlag = liftArbitrary++instance Arbitrary RepoName where+    -- TODO: rename refinement?+    arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) where+      mk = (:) <$> lead <*> rest+      lead = elements+        [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."]+      rest = listOf (elements+        [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` "_-."])++instance Arbitrary ReportLevel where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary OverwritePolicy where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary InstallMethod where+    arbitrary = arbitraryBoundedEnum++-------------------------------------------------------------------------------+-- ActiveRepos+-------------------------------------------------------------------------------++instance Arbitrary ActiveRepos where+    arbitrary = ActiveRepos <$> shortListOf 5 arbitrary++instance Arbitrary ActiveRepoEntry where+    arbitrary = frequency+        [ (10, ActiveRepo <$> arbitrary <*> arbitrary)+        , (1, ActiveRepoRest <$> arbitrary)+        ]++instance Arbitrary CombineStrategy where+    arbitrary = arbitraryBoundedEnum+    shrink    = shrinkBoundedEnum++-------------------------------------------------------------------------------+-- AllowNewer+-------------------------------------------------------------------------------++instance Arbitrary AllowNewer where+    arbitrary = AllowNewer <$> arbitrary++instance Arbitrary AllowOlder where+    arbitrary = AllowOlder <$> arbitrary++instance Arbitrary RelaxDeps where+    arbitrary = oneof [ pure mempty+                      , mkRelaxDepSome <$> shortListOf1 3 arbitrary+                      , pure RelaxDepsAll+                      ]++instance Arbitrary RelaxDepMod where+    arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]++    shrink RelaxDepModCaret = [RelaxDepModNone]+    shrink _                = []++instance Arbitrary RelaxDepScope where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary RelaxDepSubject where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary RelaxedDep where+    arbitrary = genericArbitrary+    shrink    = genericShrink++-------------------------------------------------------------------------------+-- UserConstraint+-------------------------------------------------------------------------------++instance Arbitrary UserConstraintScope where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary UserQualifier where+    arbitrary = oneof [ pure UserQualToplevel+                      , UserQualSetup <$> arbitrary++                      -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.+                      -- , UserQualExe <$> arbitrary <*> arbitrary+                      ]+++instance Arbitrary UserConstraint where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary PackageProperty where+    arbitrary = oneof [ PackagePropertyVersion <$> arbitrary+                      , pure PackagePropertyInstalled+                      , pure PackagePropertySource+                      , PackagePropertyFlags  . mkFlagAssignment <$> shortListOf1 3 arbitrary+                      , PackagePropertyStanzas . (\x->[x]) <$> arbitrary+                      ]++instance Arbitrary OptionalStanza where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary OptionalStanzaSet where+    arbitrary = fmap optStanzaSetFromList arbitrary++instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where+    arbitrary = do+        x1 <- arbitrary+        x2 <- arbitrary+        return $ optStanzaTabulate $ \x -> case x of+            TestStanzas  -> x1+            BenchStanzas -> x2++-------------------------------------------------------------------------------+-- BuildReport+-------------------------------------------------------------------------------++instance Arbitrary BuildReport where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary InstallOutcome where+    arbitrary = genericArbitrary+    shrink    = genericShrink++instance Arbitrary Outcome where+    arbitrary = genericArbitrary+    shrink    = genericShrink++-------------------------------------------------------------------------------+-- Glob+-------------------------------------------------------------------------------++instance Arbitrary FilePathGlob where+  arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary)+                `suchThat` validFilePathGlob++  shrink (FilePathGlob root pathglob) =+    [ FilePathGlob root' pathglob'+    | (root', pathglob') <- shrink (root, pathglob)+    , validFilePathGlob (FilePathGlob root' pathglob') ]++validFilePathGlob :: FilePathGlob -> Bool+validFilePathGlob (FilePathGlob FilePathRelative pathglob) =+  case pathglob of+    GlobDirTrailing             -> False+    GlobDir [Literal "~"] _     -> False+    GlobDir [Literal (d:":")] _+      | isLetter d              -> False+    _                           -> True+validFilePathGlob _ = True++instance Arbitrary FilePathRoot where+  arbitrary =+    frequency+      [ (3, pure FilePathRelative)+      , (1, pure (FilePathRoot unixroot))+      , (1, FilePathRoot <$> windrive)+      , (1, pure FilePathHomeDir)+      ]+    where+      unixroot = "/"+      windrive = do d <- choose ('A', 'Z'); return (d : ":\\")++  shrink FilePathRelative     = []+  shrink (FilePathRoot _)     = [FilePathRelative]+  shrink FilePathHomeDir      = [FilePathRelative]+++instance Arbitrary FilePathGlobRel where+  arbitrary = sized $ \sz ->+    oneof $ take (max 1 sz)+      [ pure GlobDirTrailing+      , GlobFile  <$> (getGlobPieces <$> arbitrary)+      , GlobDir   <$> (getGlobPieces <$> arbitrary)+                  <*> resize (sz `div` 2) arbitrary+      ]++  shrink GlobDirTrailing = []+  shrink (GlobFile glob) =+      GlobDirTrailing+    : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ]+  shrink (GlobDir glob pathglob) =+      pathglob+    : GlobFile glob+    : [ GlobDir (getGlobPieces glob') pathglob'+      | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ]++newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] }+  deriving Eq++instance Arbitrary GlobPieces where+  arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary++  shrink (GlobPieces glob) =+    [ GlobPieces (mergeLiterals (getNonEmpty glob'))+    | glob' <- shrink (NonEmpty glob) ]++mergeLiterals :: [GlobPiece] -> [GlobPiece]+mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps)+mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps+mergeLiterals (p:ps) = p : mergeLiterals ps+mergeLiterals []     = []++instance Arbitrary GlobPiece where+  arbitrary = sized $ \sz ->+    frequency+      [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars))+      , (1, pure WildCard)+      , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary)))+      ]++  shrink (Literal str) = [ Literal str'+                         | str' <- shrink str+                         , not (null str')+                         , all (`elem` globLiteralChars) str' ]+  shrink WildCard       = []+  shrink (Union as)     = [ Union (map getGlobPieces (getNonEmpty as'))+                          | as' <- shrink (NonEmpty (map GlobPieces as)) ]++globLiteralChars :: [Char]+globLiteralChars = ['\0'..'\128'] \\ "*{},/\\"
+ tests/UnitTests/Distribution/Client/BuildReport.hs view
@@ -0,0 +1,32 @@+module UnitTests.Distribution.Client.BuildReport (+    tests,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()+import UnitTests.Distribution.Client.ArbitraryInstances ()+import UnitTests.Distribution.Client.TreeDiffInstances ()++import Data.TreeDiff.QuickCheck (ediffEq)+import Test.QuickCheck          (Property, counterexample)+import Test.Tasty               (TestTree)+import Test.Tasty.QuickCheck    (testProperty)++import Distribution.Client.BuildReports.Anonymous (BuildReport, parseBuildReport, showBuildReport)+import Distribution.Simple.Utils                  (toUTF8BS)++-- instances+import Test.QuickCheck.Instances.Cabal ()++tests :: [TestTree]+tests =+    [ testProperty "test" roundtrip+    ]++roundtrip :: BuildReport -> Property+roundtrip br =+    counterexample str $+    Right br `ediffEq` parseBuildReport (toUTF8BS str)+  where+    str :: String+    str = showBuildReport br
+ tests/UnitTests/Distribution/Client/Configure.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE RecordWildCards #-}+module UnitTests.Distribution.Client.Configure (tests) where++import Distribution.Client.CmdConfigure++import Test.Tasty+import Test.Tasty.HUnit+import Control.Monad+import qualified Data.Map as Map+import System.Directory+import System.FilePath+import Distribution.Verbosity+import Distribution.Client.Setup+import Distribution.Client.NixStyleOptions+import Distribution.Client.ProjectConfig.Types+import Distribution.Client.ProjectFlags+import Distribution.Simple+import Distribution.Simple.Flag++tests :: [TestTree]+tests = +    [ configureTests+    ]++configureTests :: TestTree+configureTests = testGroup "Configure tests"+    [ testCase "New config" $ do+        let flags = (defaultNixStyleFlags ()) +              { configFlags = mempty+                  { configOptimization = Flag MaximumOptimisation+                  , configVerbosity = Flag silent+                  }+              }+        projConfig <- configureAction' flags [] defaultGlobalFlags+        +        Flag MaximumOptimisation @=?+          (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig)++    , testCase "Replacement + new config" $ do+        let flags = (defaultNixStyleFlags ()) +              { configExFlags = mempty+                  { configAppend = Flag True }+              , configFlags = mempty+                  { configOptimization = Flag NoOptimisation+                  , configVerbosity = Flag silent+                  }+              , projectFlags = mempty+                  { flagProjectFileName = Flag projectFile }+              }+        (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags++        Flag NoOptimisation @=? packageConfigOptimization projectConfigLocalPackages+        Flag silent         @=? projectConfigVerbosity projectConfigBuildOnly+    +    , testCase "Old + new config" $ do+        let flags = (defaultNixStyleFlags ()) +              { configExFlags = mempty+                  { configAppend = Flag True }+              , configFlags = mempty+                  { configVerbosity = Flag silent }+              , projectFlags = mempty+                  { flagProjectFileName = Flag projectFile }+              }+        (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags++        Flag MaximumOptimisation @=? packageConfigOptimization projectConfigLocalPackages+        Flag silent              @=? projectConfigVerbosity projectConfigBuildOnly+    +    , testCase "Old + new config, no appending" $ do+        let flags = (defaultNixStyleFlags ()) +              { configFlags = mempty+                  { configVerbosity = Flag silent }+              , projectFlags = mempty+                  { flagProjectFileName = Flag projectFile }+              }+        (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags++        NoFlag      @=? packageConfigOptimization projectConfigLocalPackages+        Flag silent @=? projectConfigVerbosity projectConfigBuildOnly+    +    , testCase "Old + new config, backup check" $ do+        let flags = (defaultNixStyleFlags ()) +              { configFlags = mempty+                  { configVerbosity = Flag silent }+              , projectFlags = mempty+                  { flagProjectFileName = Flag projectFile }+              }+            backup = projectFile <.> "local~"++        exists <- doesFileExist backup+        when exists $ +          removeFile backup++        _ <- configureAction' flags [] defaultGlobalFlags++        doesFileExist backup >>=+          assertBool ("No file found, expected: " ++ backup)++    , testCase "Local program options" $ do+        let ghcFlags = ["-fno-full-laziness"]+            flags = (defaultNixStyleFlags ())+              { configFlags = mempty+                  { configVerbosity = Flag silent+                  , configProgramArgs = [("ghc", ghcFlags)]+                  }+              , projectFlags = mempty+                  { flagProjectFileName = Flag projectFile }+              }+        (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags+++        assertEqual "global"+                    Nothing+                    (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages)))++        assertEqual "local"+                    (Just ghcFlags)+                    (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages)))+    ]++projectFile :: FilePath+projectFile = "tests" </> "fixtures" </> "configure" </> "cabal.project"
+ tests/UnitTests/Distribution/Client/Described.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module UnitTests.Distribution.Client.Described where++import Distribution.Client.Compat.Prelude+import Prelude ()+import Test.QuickCheck.Instances.Cabal ()+import UnitTests.Distribution.Client.ArbitraryInstances ()+import UnitTests.Distribution.Client.DescribedInstances ()++import Distribution.Described (testDescribed)+import Test.Tasty             (TestTree, testGroup)++import Distribution.Client.BuildReports.Types     (InstallOutcome, Outcome)+import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos)+import Distribution.Client.IndexUtils.IndexState  (RepoIndexState, TotalIndexState)+import Distribution.Client.IndexUtils.Timestamp   (Timestamp)+import Distribution.Client.Targets                (UserConstraint)+import Distribution.Client.Types                  (RepoName)+import Distribution.Client.Types.AllowNewer       (RelaxDepSubject, RelaxDeps, RelaxedDep)++tests :: TestTree+tests = testGroup "Described"+    [ testDescribed (Proxy :: Proxy Timestamp)+    , testDescribed (Proxy :: Proxy RepoIndexState)+    , testDescribed (Proxy :: Proxy TotalIndexState)+    , testDescribed (Proxy :: Proxy RepoName)+    , testDescribed (Proxy :: Proxy ActiveRepos)+    , testDescribed (Proxy :: Proxy RelaxDepSubject)+    , testDescribed (Proxy :: Proxy RelaxedDep)+    , testDescribed (Proxy :: Proxy RelaxDeps)+    , testDescribed (Proxy :: Proxy UserConstraint)+    , testDescribed (Proxy :: Proxy InstallOutcome)+    , testDescribed (Proxy :: Proxy Outcome)+    ]
+ tests/UnitTests/Distribution/Client/DescribedInstances.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module UnitTests.Distribution.Client.DescribedInstances where++import Distribution.Client.Compat.Prelude++import Distribution.Described+import Data.List ((\\))++import Distribution.Types.PackageId    (PackageIdentifier)+import Distribution.Types.PackageName  (PackageName)+import Distribution.Types.VersionRange (VersionRange)++import Distribution.Client.BuildReports.Types     (InstallOutcome, Outcome)+import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy)+import Distribution.Client.IndexUtils.IndexState  (RepoIndexState, TotalIndexState)+import Distribution.Client.IndexUtils.Timestamp   (Timestamp)+import Distribution.Client.Targets                (UserConstraint)+import Distribution.Client.Types                  (RepoName)+import Distribution.Client.Types.AllowNewer       (RelaxDepSubject, RelaxDeps, RelaxedDep)+import Distribution.Client.Glob                   (FilePathGlob)++-------------------------------------------------------------------------------+-- BuildReport+-------------------------------------------------------------------------------++instance Described InstallOutcome where+    describe _ = REUnion+        [ "PlanningFailed"+        , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier)+        , "DownloadFailed"+        , "UnpackFailed"+        , "SetupFailed"+        , "ConfigureFailed"+        , "BuildFailed"+        , "TestsFailed"+        , "InstallFailed"+        , "InstallOk"+        ]+instance Described Outcome where+    describe _ = REUnion+        [ fromString (prettyShow o)+        | o <- [minBound .. maxBound :: Outcome]+        ]++-------------------------------------------------------------------------------+-- Glob+-------------------------------------------------------------------------------++-- This instance is incorrect as it may generate C:\dir\{foo,bar}+instance Described FilePathGlob where+    describe _ = REUnion [ root, relative, homedir ] where+        root = REUnion+            [ fromString "/"+            , reChars (['a'..'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\"+            ] <> REOpt pieces+        homedir = "~/" <> REOpt pieces+        relative = pieces++        pieces :: GrammarRegex void+        pieces = REMunch1 sep piece <> REOpt "/"++        piece :: GrammarRegex void+        piece = RERec "glob" $ REMunch1 mempty $ REUnion+            [ normal+            , escape+            , wildcard+            , "{" <> REMunch1 "," (REVar Nothing) <> "}"+            ]++        sep :: GrammarRegex void+        sep = reChars "/\\"++        wildcard :: GrammarRegex void+        wildcard = "*"++        normal   = reChars $ ['\0'..'\128'] \\ "*{},/\\"+        escape   = fromString "\\" <> reChars "*{},"++-------------------------------------------------------------------------------+-- AllowNewer+-------------------------------------------------------------------------------++instance Described RelaxedDep where+    describe _ =+        REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))+        <> describe (Proxy :: Proxy RelaxDepSubject)+      where+        describeRelaxDepScope = REUnion+            [ "*"+            , "all"+            , RENamed "package-name" (describe (Proxy :: Proxy PackageName))+            , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))+            ]++instance Described RelaxDepSubject where+    describe _ = REUnion+        [ "*"+        , "all"+        , RENamed "package-name" (describe (Proxy :: Proxy PackageName))+        ]++instance Described RelaxDeps where+    describe _ = REUnion+        [ "*"+        , "all"+        , "none"+        , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))+        ]++-------------------------------------------------------------------------------+-- ActiveRepos+-------------------------------------------------------------------------------++instance Described ActiveRepos where+    describe _ = REUnion+        [ ":none"+        , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))+        ]++instance Described ActiveRepoEntry where+    describe _ = REUnion+        [ ":rest" <> strategy+        , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy+        ]+      where+        strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)++instance Described CombineStrategy where+    describe _ = REUnion+        [ "skip"+        , "merge"+        , "override"+        ]++-------------------------------------------------------------------------------+-- UserConstraint+-------------------------------------------------------------------------------++instance Described UserConstraint where+    describe _ = REAppend+        [ describeConstraintScope+        , describeConstraintProperty+        ]+      where+        describeConstraintScope :: GrammarRegex void+        describeConstraintScope = REUnion+            [ "any." <> describePN+            , "setup." <> describePN+            , describePN+            , describePN <> ":setup." <> describePN+            ]++        describeConstraintProperty :: GrammarRegex void+        describeConstraintProperty = REUnion+            [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange))+            , RESpaces1 <> describeConstraintProperty'+            ]++        describeConstraintProperty' :: GrammarRegex void+        describeConstraintProperty' = REUnion+            [ "installed"+            , "source"+            , "test"+            , "bench"+            , describeFlagAssignmentNonEmpty+            ]++        describePN :: GrammarRegex void+        describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName))++-------------------------------------------------------------------------------+-- IndexState+-------------------------------------------------------------------------------++instance Described TotalIndexState where+    describe _ = reCommaNonEmpty $ REUnion+        [ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris+        , ris+        ]+      where+        ris = describe (Proxy :: Proxy RepoIndexState)++instance Described RepoName where+    describe _ = lead <> rest where+        lead = RECharSet $ csAlpha    <> "_-."+        rest = reMunchCS $ csAlphaNum <> "_-."++instance Described RepoIndexState where+    describe _ = REUnion+        [ "HEAD"+        , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))+        ]++instance Described Timestamp where+    describe _ =  REUnion+        [ posix+        , utc+        ]+      where+        posix = reChar '@' <> reMunch1CS "0123456789"+        utc   = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z'++        date = REOpt digit <> REUnion+            [ leapYear   <> reChar '-' <> leapMD+            , commonYear <> reChar '-' <> commonMD+            ]++        -- leap year: either+        -- * divisible by 400+        -- * not divisible by 100 and divisible by 4+        leapYear = REUnion+            [ div4           <> "00"+            , digit <> digit <> div4not0+            ]++        -- common year: either+        -- * not divisible by 400 but divisible by 100+        -- * not divisible by 4+        commonYear = REUnion+            [ notDiv4        <> "00"+            , digit <> digit <> notDiv4+            ]++        div4 = REUnion+            [ "0" <> reChars "048"+            , "1" <> reChars "26"+            , "2" <> reChars "048"+            , "3" <> reChars "26"+            , "4" <> reChars "048"+            , "5" <> reChars "26"+            , "6" <> reChars "048"+            , "7" <> reChars "26"+            , "8" <> reChars "048"+            , "9" <> reChars "26"+            ]++        div4not0 = REUnion+            [ "0" <> reChars "48" -- no zero+            , "1" <> reChars "26"+            , "2" <> reChars "048"+            , "3" <> reChars "26"+            , "4" <> reChars "048"+            , "5" <> reChars "26"+            , "6" <> reChars "048"+            , "7" <> reChars "26"+            , "8" <> reChars "048"+            , "9" <> reChars "26"+            ]++        notDiv4 = REUnion+            [ "0" <> reChars "1235679"+            , "1" <> reChars "01345789"+            , "2" <> reChars "1235679"+            , "3" <> reChars "01345789"+            , "4" <> reChars "1235679"+            , "5" <> reChars "01345789"+            , "6" <> reChars "1235679"+            , "7" <> reChars "01345789"+            , "8" <> reChars "1235679"+            , "9" <> reChars "01345789"+            ]++        leapMD = REUnion+            [ jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]++        commonMD = REUnion+            [ jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]++        jan = "01-" <> d31+        feb = "02-" <> d28+        fe' = "02-" <> d29+        mar = "03-" <> d31+        apr = "04-" <> d30+        may = "05-" <> d31+        jun = "06-" <> d30+        jul = "07-" <> d31+        aug = "08-" <> d31+        sep = "09-" <> d30+        oct = "10-" <> d31+        nov = "11-" <> d30+        dec = "12-" <> d31++        d28 = REUnion+            [ "0" <> digit1, "1" <> digit, "2" <> reChars "012345678" ]+        d29 = REUnion+            [ "0" <> digit1, "1" <> digit, "2" <> digit ]+        d30 = REUnion+            [ "0" <> digit1, "1" <> digit, "2" <> digit, "30" ]+        d31 = REUnion+            [ "0" <> digit1, "1" <> digit, "2" <> digit, "30", "31" ]++        time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec++        -- 0..23+        ho = REUnion+            [ "0" <> digit+            , "1" <> digit+            , "2" <> reChars "0123"+            ]++        -- 0..59+        minSec = reChars "012345" <> digit++        digit  = reChars "0123456789"+        digit1 = reChars  "123456789"
+ tests/UnitTests/Distribution/Client/FetchUtils.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE ScopedTypeVariables #-}+module UnitTests.Distribution.Client.FetchUtils+  ( tests,+  )+where++import Control.Concurrent (threadDelay)+import Control.Exception+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import Distribution.Client.FetchUtils+import Distribution.Client.GlobalFlags (RepoContext (..))+import Distribution.Client.HttpUtils (HttpCode, HttpTransport (..))+import Distribution.Client.Types.PackageLocation (PackageLocation (..), ResolvedPkgLoc)+import Distribution.Client.Types.Repo (Repo (..), emptyRemoteRepo)+import Distribution.Client.Types.RepoName (RepoName (..))+import Distribution.Types.PackageId (PackageIdentifier (..))+import Distribution.Types.PackageName (mkPackageName)+import qualified Distribution.Verbosity as Verbosity+import Distribution.Version (mkVersion)+import Network.URI (URI, uriPath)+import Test.Tasty+import Test.Tasty.HUnit+import UnitTests.TempTestDir (withTestDir)++tests :: [TestTree]+tests =+  [ testGroup+      "asyncFetchPackages"+      [ testCase "handles an empty package list" testEmpty,+        testCase "passes an unpacked local package through" testPassLocalPackage,+        testCase "handles http" testHttp,+        testCase "aborts on interrupt in GET" $ testGetInterrupt,+        testCase "aborts on other exception in GET" $ testGetException,+        testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt,+        testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException+      ]+  ]++verbosity :: Verbosity.Verbosity+verbosity = Verbosity.silent++-- | An interval that we use to assert that something happens "immediately".+-- Must be shorter than 'longSleep' to ensure those are interrupted.+-- 1s would be a reasonable value, but failed tempfile cleanup on Windows CI+-- takes ~1s.+shortDelta :: NominalDiffTime+shortDelta = 5 -- 5s++longSleep :: IO ()+longSleep = threadDelay 10000000 -- 10s++testEmpty :: Assertion+testEmpty = do+  let repoCtxt = undefined+      pkgLocs = []+  res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \_ ->+    return ()+  res @?= ()++testPassLocalPackage :: Assertion+testPassLocalPackage = do+  let repoCtxt = error "repoCtxt undefined"+      loc = LocalUnpackedPackage "a"+  res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap ->+    waitAsyncFetchPackage verbosity downloadMap loc+  res @?= LocalUnpackedPackage "a"++testHttp :: Assertion+testHttp = withFakeRepoCtxt get200 $ \repoCtxt repo -> do+  let pkgId = mkPkgId "foo"+      loc = RepoTarballPackage repo pkgId Nothing+  res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap ->+    waitAsyncFetchPackage verbosity downloadMap loc+  case res of+    RepoTarballPackage repo' pkgId' _ -> do+      repo' @?= repo+      pkgId' @?= pkgId+    _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res+  where+    get200 = \_uri -> return 200++testGetInterrupt :: Assertion+testGetInterrupt = testGetAny UserInterrupt++testGetException :: Assertion+testGetException = testGetAny $ userError "some error"++-- | Test that if a GET request fails with the given exception,+-- we exit promptly. We queue two slow downloads after the failing+-- download to cover a buggy scenario where+-- 1. first download throws+-- 2. second download is cancelled, but swallows AsyncCancelled+-- 3. third download keeps running+testGetAny :: Exception e => e -> Assertion+testGetAny exc = withFakeRepoCtxt get $ \repoCtxt repo -> do+  let loc pkgId = RepoTarballPackage repo pkgId Nothing+      pkgLocs = [loc throws, loc slowA, loc slowB]++  start <- getCurrentTime+  res :: Either SomeException ResolvedPkgLoc <-+    try $+      asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do+        waitAsyncFetchPackage verbosity downloadMap (loc throws)+  assertFaster start shortDelta+  case res of+    Left _ -> pure ()+    Right _ -> assertFailure $ "expected an exception, got " ++ show res+  where+    throws = mkPkgId "throws"+    slowA = mkPkgId "slowA"+    slowB = mkPkgId "slowB"+    get uri = case uriPath uri of+      "package/throws-1.0.tar.gz" -> throwIO exc+      "package/slowA-1.0.tar.gz" -> longSleep >> return 200+      "package/slowB-1.0.tar.gz" -> longSleep >> return 200+      _ -> assertFailure $ "unexpected URI: " ++ show uri++-- | Test that when an undemanded download is interrupted (Ctrl-C),+-- we still abort directly.+testUncollectedInterrupt :: Assertion+testUncollectedInterrupt = withFakeRepoCtxt get $ \repoCtxt repo -> do+  let loc pkgId = RepoTarballPackage repo pkgId Nothing+      pkgLocs = [loc throws, loc slowA, loc slowB]++  start <- getCurrentTime+  res :: Either SomeException ResolvedPkgLoc <-+    try $+      asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do+        waitAsyncFetchPackage verbosity downloadMap (loc slowA)+  assertFaster start shortDelta+  case res of+    Left _ -> pure ()+    Right _ -> assertFailure $ "expected an exception, got " ++ show res+  where+    throws = mkPkgId "throws"+    slowA = mkPkgId "slowA"+    slowB = mkPkgId "slowB"+    get uri = case uriPath uri of+      "package/throws-1.0.tar.gz" -> throwIO UserInterrupt+      "package/slowA-1.0.tar.gz" -> longSleep >> return 200+      "package/slowB-1.0.tar.gz" -> longSleep >> return 200+      _ -> assertFailure $ "unexpected URI: " ++ show uri++-- | Test that a download failure doesn't automatically abort things,+-- e.g. if we don't collect the download. (In practice, we might collect+-- the download and handle its exception.)+testUncollectedException :: Assertion+testUncollectedException = withFakeRepoCtxt get $ \repoCtxt repo -> do+  let loc pkgId = RepoTarballPackage repo pkgId Nothing+      pkgLocs = [loc throws, loc foo]++  start <- getCurrentTime+  res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do+    waitAsyncFetchPackage verbosity downloadMap (loc foo)+  assertFaster start shortDelta+  case res of+    RepoTarballPackage repo' pkgId' _ -> do+      repo' @?= repo+      pkgId' @?= foo+    _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res+  where+    throws = mkPkgId "throws"+    foo = mkPkgId "foo"+    get uri = case uriPath uri of+      "package/throws-1.0.tar.gz" -> throwIO $ userError "failed download"+      "package/foo-1.0.tar.gz" -> return 200+      _ -> assertFailure $ "unexpected URI: " ++ show uri++assertFaster :: UTCTime -> NominalDiffTime -> Assertion+assertFaster start delta = do+  t <- getCurrentTime+  assertBool ("took longer than " ++ show delta) (diffUTCTime t start < delta)++mkPkgId :: String -> PackageIdentifier+mkPkgId name = PackageIdentifier (mkPackageName name) (mkVersion [1, 0])++-- | Provide a repo and a repo context with the given GET handler.+withFakeRepoCtxt ::+  (URI -> IO HttpCode) ->+  (RepoContext -> Repo -> IO a) ->+  IO a+withFakeRepoCtxt handleGet action =+  withTestDir verbosity "fake repo" $ \tmpDir ->+    let repo =+          RepoRemote+            { repoRemote = emptyRemoteRepo $ RepoName "fake",+              repoLocalDir = tmpDir+            }+        repoCtxt =+          RepoContext+            { repoContextRepos = [repo],+              repoContextGetTransport = return httpTransport,+              repoContextWithSecureRepo = \_ _ ->+                error "fake repo ctxt: repoContextWithSecureRepo not implemented",+              repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented"+            }+     in action repoCtxt repo+  where+    httpTransport =+      HttpTransport+        { getHttp = \_verbosity uri _etag _filepath _headers -> do+            code <- handleGet uri+            return (code, Nothing),+          postHttp = error "fake transport: postHttp not implemented",+          postHttpFile = error "fake transport: postHttpFile not implemented",+          putHttpFile = error "fake transport: putHttp not implemented",+          transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented",+          transportManuallySelected = True+        }
+ tests/UnitTests/Distribution/Client/FileMonitor.hs view
@@ -0,0 +1,877 @@+module UnitTests.Distribution.Client.FileMonitor (tests) where++import Distribution.Parsec (simpleParsec)++import Data.Proxy (Proxy (..))+import Control.Monad+import Control.Exception+import Control.Concurrent (threadDelay)+import qualified Data.Set as Set+import System.FilePath+import qualified System.Directory as IO+import Prelude hiding (writeFile)+import qualified Prelude as IO (writeFile)++import Distribution.Compat.Binary+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.System (buildOS, OS (Windows))+import Distribution.Verbosity (silent)++import Distribution.Client.FileMonitor+import Distribution.Compat.Time+import Distribution.Utils.Structured (structureHash, Structured)+import GHC.Fingerprint (Fingerprint (..))++import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit+++tests :: Int -> [TestTree]+tests mtimeChange =+  [ testGroup "Structured hashes"+    [ testCase "MonitorStateFile"    $ structureHash (Proxy :: Proxy MonitorStateFile)    @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13+    , testCase "MonitorStateGlob"    $ structureHash (Proxy :: Proxy MonitorStateGlob)    @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6+    , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27+    ]+  , testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange+  , testCase "sanity check dirs"     $ testDirChangeSanity mtimeChange+  , testCase "no monitor cache"      testNoMonitorCache+  , testCaseSteps "corrupt monitor cache" testCorruptMonitorCache+  , testCase "empty monitor"         testEmptyMonitor+  , testCase "missing file"          testMissingFile+  , testCase "change file"           $ testChangedFile mtimeChange+  , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange+  , testCase "update during action"  $ testUpdateDuringAction mtimeChange+  , testCase "remove file"           testRemoveFile+  , testCase "non-existent file"     testNonExistentFile+  , testCase "changed file type"     $ testChangedFileType mtimeChange+  , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange++  , testGroup "glob matches"+    [ testCase "no change"           testGlobNoChange+    , testCase "add match"           $ testGlobAddMatch mtimeChange+    , testCase "remove match"        $ testGlobRemoveMatch mtimeChange+    , testCase "change match"        $ testGlobChangeMatch mtimeChange++    , testCase "add match subdir"    $ testGlobAddMatchSubdir mtimeChange+    , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange+    , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange++    , testCase "match toplevel dir"  $ testGlobMatchTopDir mtimeChange+    , testCase "add non-match"       $ testGlobAddNonMatch mtimeChange+    , testCase "remove non-match"    $ testGlobRemoveNonMatch mtimeChange++    , knownBrokenInWindows "See issue #3126" $+      testCase "add non-match subdir"    $ testGlobAddNonMatchSubdir mtimeChange+    , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange++    , testCase "invariant sorted 1"  $ testInvariantMonitorStateGlobFiles+                                         mtimeChange+    , testCase "invariant sorted 2"  $ testInvariantMonitorStateGlobDirs+                                         mtimeChange++    , testCase "match dirs"          $ testGlobMatchDir mtimeChange+    , knownBrokenInWindows "See issue #3126" $+      testCase "match dirs only"     $ testGlobMatchDirOnly mtimeChange+    , testCase "change file type"    $ testGlobChangeFileType mtimeChange+    , testCase "absolute paths"      $ testGlobAbsolutePath mtimeChange+    ]++  , testCase "value unchanged"       testValueUnchanged+  , testCase "value changed"         testValueChanged+  , testCase "value & file changed"  $ testValueAndFileChanged mtimeChange+  , testCase "value updated"         testValueUpdated+  ]++  where knownBrokenInWindows msg =  case buildOS of+          Windows -> expectFailBecause msg+          _       -> id++-- Check the file system behaves the way we expect it to++-- we rely on file mtimes having a reasonable resolution+testFileMTimeSanity :: Int -> Assertion+testFileMTimeSanity mtimeChange =+  withTempDirectory silent "." "file-status-" $ \dir -> do+    replicateM_ 10 $ do+      IO.writeFile (dir </> "a") "content"+      t1 <- getModTime (dir </> "a")+      threadDelay mtimeChange+      IO.writeFile (dir </> "a") "content"+      t2 <- getModTime (dir </> "a")+      assertBool "expected different file mtimes" (t2 > t1)++-- We rely on directories changing mtime when entries are added or removed+testDirChangeSanity :: Int -> Assertion+testDirChangeSanity mtimeChange =+  withTempDirectory silent "." "dir-mtime-" $ \dir -> do++    expectMTimeChange dir "file add" $+      IO.writeFile (dir </> "file") "content"++    expectMTimeSame dir "file content change" $+      IO.writeFile (dir </> "file") "new content"++    expectMTimeChange dir "file del" $+      IO.removeFile (dir </> "file")++    expectMTimeChange dir "subdir add" $+      IO.createDirectory (dir </> "dir")++    expectMTimeSame dir "subdir file add" $+      IO.writeFile (dir </> "dir" </> "file") "content"++    expectMTimeChange dir "subdir file move in" $+      IO.renameFile (dir </> "dir" </> "file") (dir </> "file")++    expectMTimeChange dir "subdir file move out" $+      IO.renameFile (dir </> "file") (dir </> "dir" </> "file")++    expectMTimeSame dir "subdir dir add" $+      IO.createDirectory (dir </> "dir" </> "subdir")++    expectMTimeChange dir "subdir dir move in" $+      IO.renameDirectory (dir </> "dir" </> "subdir") (dir </> "subdir")++    expectMTimeChange dir "subdir dir move out" $+      IO.renameDirectory (dir </> "subdir") (dir </> "dir" </> "subdir")++  where+    expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO ()+                                       -> Assertion++    expectMTimeChange dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected dir mtime change on " ++ descr) (t' > t)++    expectMTimeSame dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected same dir mtime on " ++ descr) (t' == t)+++-- Now for the FileMonitor tests proper...++-- first run, where we don't even call updateMonitor+testNoMonitorCache :: Assertion+testNoMonitorCache =+  withFileMonitor $ \root monitor -> do+    reason <- expectMonitorChanged root (monitor :: FileMonitor () ()) ()+    reason @?= MonitorFirstRun++-- write garbage into the binary cache file+testCorruptMonitorCache :: (String -> IO ()) -> Assertion+testCorruptMonitorCache step =+  withFileMonitor $ \root monitor -> do+    step "Writing broken file"+    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitorCorruptCache++    step "Updating file monitor"+    updateMonitor root monitor [] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++    step "Writing broken file again"+    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitorCorruptCache++-- no files to monitor+testEmptyMonitor :: Assertion+testEmptyMonitor =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [] () ()+    touchFile root "b"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++-- monitor a file that is expected to exist+testMissingFile :: Assertion+testMissingFile = do+    test monitorFile       touchFile  "a"+    test monitorFileHashed touchFile  "a"+    test monitorFile       touchFile ("dir" </> "a")+    test monitorFileHashed touchFile ("dir" </> "a")+    test monitorDirectory  touchDir   "a"+    test monitorDirectory  touchDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch file =+      withFileMonitor $ \root monitor -> do+        -- a file that doesn't exist at snapshot time is considered to have+        -- changed+        updateMonitor root monitor [monitorKind file] () ()+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file++        -- a file doesn't exist at snapshot time, but gets added afterwards is+        -- also considered to have changed+        updateMonitor root monitor [monitorKind file] () ()+        touch root file+        reason2 <- expectMonitorChanged root monitor ()+        reason2 @?= MonitoredFileChanged file+++testChangedFile :: Int -> Assertion+testChangedFile mtimeChange = do+    test monitorFile       touchFile touchFile         "a"+    test monitorFileHashed touchFile touchFileContent  "a"+    test monitorFile       touchFile touchFile        ("dir" </> "a")+    test monitorFileHashed touchFile touchFileContent ("dir" </> "a")+    test monitorDirectory  touchDir  touchDir          "a"+    test monitorDirectory  touchDir  touchDir         ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch touch' file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        threadDelay mtimeChange+        touch' root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testChangedFileMtimeVsContent :: Int -> Assertion+testChangedFileMtimeVsContent mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- if we don't touch the file, it's unchanged+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a"]++    -- if we do touch the file, it's changed if we only consider mtime+    updateMonitor root monitor [monitorFile "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- but if we touch the file, it's unchanged if we consider content hash+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorFileHashed "a"]++    -- finally if we change the content it's changed+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFileContent root "a"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"+++testUpdateDuringAction :: Int -> Assertion+testUpdateDuringAction mtimeChange = do+    test (monitorFile        "a") touchFile "a"+    test (monitorFileHashed  "a") touchFile "a"+    test (monitorDirectory   "a") touchDir  "a"+    test (monitorFileGlobStr "*") touchFile "a"+    test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }+                                  touchDir  "a"+  where+    test :: MonitorFilePath+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorSpec touch file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorSpec] () ()++        -- start doing an update action...+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitor root monitor [monitorSpec] () ()+        -- we don't notice this change since we took the timestamp after the+        -- action finished+        (res, files) <- expectMonitorUnchanged root monitor ()+        res   @?= ()+        files @?= [monitorSpec]++        -- Let's try again, this time taking the timestamp before the action+        timestamp' <- beginUpdateFileMonitor+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () ()+        -- now we do notice the change since we took the snapshot before the+        -- action finished+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testRemoveFile :: Assertion+testRemoveFile = do+    test monitorFile       touchFile removeFile  "a"+    test monitorFileHashed touchFile removeFile  "a"+    test monitorFile       touchFile removeFile ("dir" </> "a")+    test monitorFileHashed touchFile removeFile ("dir" </> "a")+    test monitorDirectory  touchDir  removeDir   "a"+    test monitorDirectory  touchDir  removeDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch remove file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        remove root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++-- monitor a file that we expect not to exist+testNonExistentFile :: Assertion+testNonExistentFile =+  withFileMonitor $ \root monitor -> do+    -- a file that doesn't exist at snapshot time or check time is unchanged+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorNonExistentFile "a"]++    -- if the file then exists it has changed+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- if the file then exists at snapshot and check time it has changed+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"++    -- but if the file existed at snapshot time and doesn't exist at check time+    -- it is consider unchanged. This is unlike files we expect to exist, but+    -- that's because files that exist can have different content and actions+    -- can depend on that content, whereas if the action expected a file not to+    -- exist and it now does not, it'll give the same result, irrespective of+    -- the fact that the file might have existed in the meantime.+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    removeFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorNonExistentFile "a"]+++testChangedFileType :: Int-> Assertion+testChangedFileType mtimeChange = do+    test (monitorFile            "a") touchFile removeFile createDir+    test (monitorFileHashed      "a") touchFile removeFile createDir++    test (monitorDirectory       "a") createDir removeDir touchFile+    test (monitorFileOrDirectory "a") createDir removeDir touchFile++    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      touchFile removeFile createDir+    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      createDir removeDir touchFile+  where+    test :: MonitorFilePath+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> IO ()+    test monitorKind touch remove touch' =+      withFileMonitor $ \root monitor -> do+        touch  root "a"+        updateMonitor root monitor [monitorKind] () ()+        threadDelay mtimeChange+        remove root "a"+        touch' root "a"+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged "a"++-- Monitoring the same file with two different kinds of monitor should work+-- both should be kept, and both checked for changes.+-- We had a bug where only one monitor kind was kept per file.+-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178+testMultipleMonitorKinds :: Int -> Assertion+testMultipleMonitorKinds mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a", monitorFileHashed "a"]+    threadDelay mtimeChange+    touchFile root "a" -- not changing content, just mtime+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    createDir root "dir"+    updateMonitor root monitor [monitorDirectory "dir",+                                monitorDirectoryExistence "dir"] () ()+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "a") -- changing dir mtime, not existence+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "dir"+++------------------+-- globs+--++testGlobNoChange :: Assertion+testGlobNoChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddMatch :: Int -> Assertion+testGlobAddMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobRemoveMatch :: Int -> Assertion+testGlobRemoveMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-a")++testGlobChangeMatch :: Int -> Assertion+testGlobChangeMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++    touchFileContent root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobAddMatchSubdir :: Int -> Assertion+testGlobAddMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++testGlobRemoveMatchSubdir :: Int -> Assertion+testGlobRemoveMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")++testGlobChangeMatchSubdir :: Int -> Assertion+testGlobChangeMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++    touchFileContent root "dir/b/good-b"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++-- check nothing goes squiffy with matching in the top dir+testGlobMatchTopDir :: Int -> Assertion+testGlobMatchTopDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "*"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++testGlobAddNonMatch :: Int -> Assertion+testGlobAddNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobRemoveNonMatch :: Int -> Assertion+testGlobRemoveNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/bad"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddNonMatchSubdir :: Int -> Assertion+testGlobAddNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++testGlobRemoveNonMatchSubdir :: Int -> Assertion+testGlobRemoveNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]+++-- try and tickle a bug that happens if we don't maintain the invariant that+-- MonitorStateGlobFiles entries are sorted+testInvariantMonitorStateGlobFiles :: Int -> Assertion+testInvariantMonitorStateGlobFiles mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "d")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- so there should be no change (since we're doing content checks)+    -- but if we can get the dir entries to appear in the wrong order+    -- then if the sorted invariant is not maintained then we can fool+    -- the 'probeGlobStatus' into thinking there's changes+    removeFile root ("dir" </> "a")+    removeFile root ("dir" </> "b")+    removeFile root ("dir" </> "c")+    removeFile root ("dir" </> "d")+    touchFile root ("dir" </> "d")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]++-- same thing for the subdirs case+testInvariantMonitorStateGlobDirs :: Int -> Assertion+testInvariantMonitorStateGlobDirs mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "d" </> "file")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    removeDir root ("dir" </> "b")+    removeDir root ("dir" </> "c")+    removeDir root ("dir" </> "d")+    touchFile root ("dir" </> "d" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "a" </> "file")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/file"]++-- ensure that a glob can match a directory as well as a file+testGlobMatchDir :: Int -> Assertion+testGlobMatchDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    createDir root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- nothing changed yet+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]+    -- expect dir/b to match and be detected as changed+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")+    -- now remove dir/a and expect it to be detected as changed+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobMatchDirOnly :: Int -> Assertion+testGlobMatchDirOnly mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () ()+    threadDelay mtimeChange+    -- expect file dir/a to not match, so not detected as changed+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/"]+    -- note that checking the file monitor for changes can updates the+    -- cached dir mtimes (when it has to record that there's new matches)+    -- so we need an extra mtime delay+    threadDelay mtimeChange+    -- but expect dir/b to match+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")++testGlobChangeFileType :: Int -> Assertion+testGlobChangeFileType mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- change file to dir+    touchFile root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeFile root ("dir" </> "a")+    createDir  root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a")+    -- change dir to file+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    touchFile root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobAbsolutePath :: Int -> Assertion+testGlobAbsolutePath mtimeChange =+  withFileMonitor $ \root monitor -> do+    root' <- absoluteRoot root+    -- absolute glob, removing a file+    touchFile root ("dir/good-a")+    touchFile root ("dir/good-b")+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged (root' </> "dir" </> "good-a")+    -- absolute glob, adding a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFile root ("dir/good-a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged (root' </> "dir" </> "good-a")+    -- absolute glob, changing a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFileContent root "dir/good-b"+    reason3 <- expectMonitorChanged root monitor ()+    reason3 @?= MonitoredFileChanged (root' </> "dir" </> "good-b")+++------------------+-- value changes+--++testValueUnchanged :: Assertion+testValueUnchanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    (res, files) <- expectMonitorUnchanged root monitor 42+    res   @?= "ok"+    files @?= [monitorFile "a"]++testValueChanged :: Assertion+testValueChanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++testValueAndFileChanged :: Int -> Assertion+testValueAndFileChanged mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    -- we change the value and the file, and the value change is reported+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++    -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed+    -- then it's reported as MonitoredValueChanged+    let monitor' :: FileMonitor Int String+        monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True }+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    reason2 <- expectMonitorChanged root monitor' 43+    reason2 @?= MonitoredValueChanged 42++    -- but if a file changed too then we don't report MonitoredValueChanged+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason3 <- expectMonitorChanged root monitor' 43+    reason3 @?= MonitoredFileChanged "a"++testValueUpdated :: Assertion+testValueUpdated =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    let monitor' :: FileMonitor (Set.Set Int) String+        monitor' = (monitor :: FileMonitor (Set.Set Int) String) {+                     fileMonitorCheckIfOnlyValueChanged = True,+                     fileMonitorKeyValid = Set.isSubsetOf+                   }++    updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok"+    (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])+    res @?= "ok"++    reason <- expectMonitorChanged root monitor' (Set.fromList [42,44])+    reason @?= MonitoredValueChanged (Set.fromList [42,43])+++-------------+-- Utils++newtype RootPath = RootPath FilePath++touchFile :: RootPath -> FilePath -> IO ()+touchFile (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "touched"++touchFileContent :: RootPath -> FilePath -> IO ()+touchFileContent (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "different"++removeFile :: RootPath -> FilePath -> IO ()+removeFile (RootPath root) fname = IO.removeFile (root </> fname)++touchDir :: RootPath -> FilePath -> IO ()+touchDir root@(RootPath rootdir) dname = do+  IO.createDirectoryIfMissing True (rootdir </> dname)+  touchFile  root (dname </> "touch")+  removeFile root (dname </> "touch")++createDir :: RootPath -> FilePath -> IO ()+createDir (RootPath root) dname = do+  let path = root </> dname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.createDirectory path++removeDir :: RootPath -> FilePath -> IO ()+removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root </> dname)++absoluteRoot :: RootPath -> IO FilePath+absoluteRoot (RootPath root) = IO.canonicalizePath root++monitorFileGlobStr :: String -> MonitorFilePath+monitorFileGlobStr globstr+  | Just glob <- simpleParsec globstr = monitorFileGlob glob+  | otherwise                         = error $ "Failed to parse " ++ globstr+++expectMonitorChanged :: (Binary a, Structured a, Binary b, Structured b)+                     => RootPath -> FileMonitor a b -> a+                     -> IO (MonitorChangedReason a)+expectMonitorChanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged reason -> return reason+    MonitorUnchanged _ _  -> throwIO $ HUnitFailure Nothing "expected change"++expectMonitorUnchanged :: (Binary a, Structured a, Binary b, Structured b)+                        => RootPath -> FileMonitor a b -> a+                        -> IO (b, [MonitorFilePath])+expectMonitorUnchanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged _reason   -> throwIO $ HUnitFailure Nothing "expected no change"+    MonitorUnchanged b files -> return (b, files)++checkChanged :: (Binary a, Structured a, Binary b, Structured b)+             => RootPath -> FileMonitor a b+             -> a -> IO (MonitorChanged a b)+checkChanged (RootPath root) monitor key =+  checkFileMonitorChanged monitor root key++updateMonitor :: (Binary a, Structured a, Binary b, Structured b)+              => RootPath -> FileMonitor a b+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitor (RootPath root) monitor files key result =+  updateFileMonitor monitor root Nothing files key result++updateMonitorWithTimestamp :: (Binary a, Structured a, Binary b, Structured b)+              => RootPath -> FileMonitor a b -> MonitorTimestamp+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =+  updateFileMonitor monitor root (Just timestamp) files key result++withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c+withFileMonitor action = do+  withTempDirectory silent "." "file-status-" $ \root -> do+    let file    = root <.> "monitor"+        monitor = newFileMonitor file+    finally (action (RootPath root) monitor) $ do+      exists <- IO.doesFileExist file+      when exists $ IO.removeFile file
+ tests/UnitTests/Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,59 @@+module UnitTests.Distribution.Client.GZipUtils (+  tests+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Codec.Compression.GZip          as GZip+import Codec.Compression.Zlib          as Zlib+import Control.Exception                       (try)+import Data.ByteString                as BS    (null)+import Data.ByteString.Lazy           as BSL   (pack, toChunks)+import Data.ByteString.Lazy.Char8     as BSLL  (pack, init, length)+import Distribution.Client.GZipUtils           (maybeDecompress)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testCase "maybeDecompress" maybeDecompressUnitTest+        -- "decompress plain" property is non-trivial to state,+        -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process+        -- generating such input would essentially duplicate maybeDecompress implementation+        , testProperty "decompress zlib"  prop_maybeDecompress_zlib+        , testProperty "decompress gzip"  prop_maybeDecompress_gzip+        ]++maybeDecompressUnitTest :: Assertion+maybeDecompressUnitTest =+        assertBool "decompress plain"            (maybeDecompress original              == original)+     >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original)+     >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original)+     >> assertBool "decompress zlib"             (maybeDecompress compressedZlib        == original)+     >> assertBool "decompress gzip"             (maybeDecompress compressedGZip        == original)+     >> assertBool "have no empty chunks"        (all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib)+     >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft)+  where+    original = BSLL.pack "original uncompressed input"+    compressedZlib = Zlib.compress original+    compressedGZip = GZip.compress original++    runBrokenStream :: IO (Either SomeException ())+    runBrokenStream = try . void . evaluate . BSLL.length $ maybeDecompress (BSLL.init compressedZlib <> BSLL.pack "*")++prop_maybeDecompress_zlib :: [Word8] -> Property+prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original+  where original = BSL.pack ws+        compressedZlib = Zlib.compress original++prop_maybeDecompress_gzip :: [Word8] -> Property+prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original+  where original = BSL.pack ws+        compressedGZip = GZip.compress original++-- (Only available from "Data.Either" since 7.8.)+isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True
+ tests/UnitTests/Distribution/Client/Get.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+module UnitTests.Distribution.Client.Get (tests) where++import Distribution.Client.Get++import Distribution.Types.PackageId+import Distribution.Types.PackageName+import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..), KnownRepoType (..))+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..))+import Distribution.Verbosity as Verbosity+import Distribution.Version++import Control.Monad+import Control.Exception+import Data.Typeable+import System.FilePath+import System.Directory+import System.Exit+import System.IO.Error++import Test.Tasty+import Test.Tasty.HUnit+import UnitTests.Options (RunNetworkTests (..))+import UnitTests.TempTestDir (withTestDir)+++tests :: [TestTree]+tests =+  [ testGroup "forkPackages"+    [ testCase "no repos"                    testNoRepos+    , testCase "no repos of requested kind"  testNoReposOfKind+    , testCase "no repo type specified"      testNoRepoType+    , testCase "unsupported repo type"       testUnsupportedRepoType+    , testCase "no repo location specified"  testNoRepoLocation+    , testCase "correct repo kind selection" testSelectRepoKind+    , testCase "repo destination exists"     testRepoDestinationExists+    , testCase "git fetch failure"           testGitFetchFailed+    ]+  , askOption $ \(RunNetworkTests doRunNetTests) ->+    testGroup "forkPackages, network tests" $+    includeTestsIf doRunNetTests $+    [ testCase "git clone"                   testNetworkGitClone +    ]+  ]+  where+    includeTestsIf True xs = xs+    includeTestsIf False _ = []++++verbosity :: Verbosity+verbosity = Verbosity.silent -- for debugging try verbose++pkgidfoo :: PackageId+pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0])+++-- ------------------------------------------------------------+-- * Unit tests+-- ------------------------------------------------------------++testNoRepos :: Assertion+testNoRepos = do+    e <- assertException $+           clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos+    e @?= ClonePackageNoSourceRepos pkgidfoo+  where+    pkgrepos = [(pkgidfoo, [])]+++testNoReposOfKind :: Assertion+testNoReposOfKind = do+    e <- assertException $+           clonePackagesFromSourceRepo verbosity "." repokind pkgrepos+    e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind+  where+    pkgrepos = [(pkgidfoo, [repo])]+    repo     = emptySourceRepo RepoHead+    repokind = Just RepoThis+++testNoRepoType :: Assertion+testNoRepoType = do+    e <- assertException $+           clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos+    e @?= ClonePackageNoRepoType pkgidfoo repo+  where+    pkgrepos = [(pkgidfoo, [repo])]+    repo     = emptySourceRepo RepoHead+++testUnsupportedRepoType :: Assertion+testUnsupportedRepoType = do+    e <- assertException $+           clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos+    e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype+  where+    pkgrepos = [(pkgidfoo, [repo])]+    repo     = (emptySourceRepo RepoHead)+               { repoType     = Just repotype+               , repoLocation = Just "loc"+               }+    repo'    = SourceRepositoryPackage+               { srpType     = repotype+               , srpLocation = "loc"+               , srpTag      = Nothing+               , srpBranch   = Nothing+               , srpSubdir   = Proxy+               , srpCommand  = []+               }+    repotype = OtherRepoType "baz"+++testNoRepoLocation :: Assertion+testNoRepoLocation = do+    e <- assertException $+           clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos+    e @?= ClonePackageNoRepoLocation pkgidfoo repo+  where+    pkgrepos = [(pkgidfoo, [repo])]+    repo     = (emptySourceRepo RepoHead) {+                 repoType = Just repotype+               }+    repotype = KnownRepoType Darcs+++testSelectRepoKind :: Assertion+testSelectRepoKind =+    sequence_+      [ do e <- test requestedRepoType pkgrepos+           e @?= ClonePackageNoRepoType pkgidfoo expectedRepo++           e' <- test requestedRepoType (reverse pkgrepos)+           e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo+      | let test rt rs = assertException $+                           clonePackagesFromSourceRepo verbosity "." rt rs+      , (requestedRepoType, expectedRepo) <- cases+      ]+  where+    pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])]+    repo1    = emptySourceRepo RepoThis+    repo2    = emptySourceRepo RepoHead+    repo3    = emptySourceRepo (RepoKindUnknown "bar")+    cases    = [ (Nothing,       repo1)+               , (Just RepoThis, repo1)+               , (Just RepoHead, repo2)+               , (Just (RepoKindUnknown "bar"), repo3)+               ]+++testRepoDestinationExists :: Assertion+testRepoDestinationExists =+    withTestDir verbosity "repos" $ \tmpdir -> do+      let pkgdir = tmpdir </> "foo"+      createDirectory pkgdir+      e1 <- assertException $+              clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos+      e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -}++      removeDirectory pkgdir++      writeFile pkgdir ""+      e2 <- assertException $+              clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos+      e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -}+  where+    pkgrepos = [(pkgidfoo, [repo])]+    repo     = (emptySourceRepo RepoHead) {+                 repoType     = Just (KnownRepoType Darcs),+                 repoLocation = Just ""+               }+++testGitFetchFailed :: Assertion+testGitFetchFailed =+    withTestDir verbosity "repos" $ \tmpdir -> do+      let srcdir   = tmpdir </> "src"+          repo     = (emptySourceRepo RepoHead) {+                       repoType     = Just (KnownRepoType Git),+                       repoLocation = Just srcdir+                     }+          repo'    = SourceRepositoryPackage+                     { srpType     = KnownRepoType Git+                     , srpLocation = srcdir+                     , srpTag      = Nothing+                     , srpBranch   = Nothing+                     , srpSubdir   = Proxy+                     , srpCommand  = []+                     }+          pkgrepos = [(pkgidfoo, [repo])]+      e1 <- assertException $+              clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos+      e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128)+++testNetworkGitClone :: Assertion+testNetworkGitClone =+    withTestDir verbosity "repos" $ \tmpdir -> do+      let repo1 = (emptySourceRepo RepoHead) {+                    repoType     = Just (KnownRepoType Git),+                    repoLocation = Just "https://github.com/haskell/zlib.git"+                  }+      clonePackagesFromSourceRepo verbosity tmpdir Nothing+                                  [(mkpkgid "zlib1", [repo1])]+      assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]++      let repo2 = (emptySourceRepo RepoHead) {+                    repoType     = Just (KnownRepoType Git),+                    repoLocation = Just (tmpdir </> "zlib1")+                  }+      clonePackagesFromSourceRepo verbosity tmpdir Nothing+                                  [(mkpkgid "zlib2", [repo2])]+      assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]++      let repo3 = (emptySourceRepo RepoHead) {+                    repoType     = Just (KnownRepoType Git),+                    repoLocation = Just (tmpdir </> "zlib1"),+                    repoTag      = Just "0.5.0.0"+                  }+      clonePackagesFromSourceRepo verbosity tmpdir Nothing+                                  [(mkpkgid "zlib3", [repo3])]+      assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]+  where+    mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion [])+++-- ------------------------------------------------------------+-- * HUnit utils+-- ------------------------------------------------------------++assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e+assertException action = do+    r <- try action+    case r of+      Left e  -> return e+      Right _ -> assertFailure $ "expected exception of type "+                              ++ show (typeOf (undefined :: e)) +++-- | Expect that one line in a file matches exactly the given words (i.e. at+-- least insensitive to whitespace)+--+assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion+assertFileContains file expected = do+    c <- readFile file `catch` \e ->+           if isDoesNotExistError e+              then assertFailure $ "expected a file to exist: " ++ file+              else throwIO e+    unless (expected `elem` map words (lines c)) $+      assertFailure $ "expected the file " ++ file ++ " to contain "+                   ++ show (take 100 expected)+
+ tests/UnitTests/Distribution/Client/Glob.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.Glob (tests) where++import Distribution.Client.Compat.Prelude hiding (last)+import Prelude ()++import Distribution.Client.Glob+import Distribution.Utils.Structured (structureHash)+import UnitTests.Distribution.Client.ArbitraryInstances ()++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import GHC.Fingerprint (Fingerprint (..))++tests :: [TestTree]+tests =+  [ testProperty "print/parse roundtrip" prop_roundtrip_printparse+  , testCase     "parse examples"        testParseCases+  , testGroup "Structured hashes"+    [ testCase "GlobPiece"       $ structureHash (Proxy :: Proxy GlobPiece)       @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782+    , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98+    , testCase "FilePathRoot"    $ structureHash (Proxy :: Proxy FilePathRoot)    @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5+    , testCase "FilePathGlob"    $ structureHash (Proxy :: Proxy FilePathGlob)    @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024+    ]+  ]++--TODO: [nice to have] tests for trivial globs, tests for matching,+-- tests for windows style file paths++prop_roundtrip_printparse :: FilePathGlob -> Property+prop_roundtrip_printparse pathglob =+    counterexample (prettyShow pathglob) $+    eitherParsec (prettyShow pathglob) === Right pathglob++-- first run, where we don't even call updateMonitor+testParseCases :: Assertion+testParseCases = do++  FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"+  FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/"++  FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"+  FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"+  FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"+  FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "."]) <- testparse "."++  FilePathGlob FilePathRelative+    (GlobFile [Literal "~"]) <- testparse "~"++  FilePathGlob FilePathRelative+    (GlobDir  [Literal "."] GlobDirTrailing) <- testparse "./"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo"]) <- testparse "foo"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobFile [Literal "bar"])) <- testparse "foo/bar"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"++  FilePathGlob (FilePathRoot "/")+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"++  FilePathGlob (FilePathRoot "C:\\")+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "C:\\foo\\bar\\"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard]) <- testparse "*"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid++  FilePathGlob FilePathRelative+    (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar"++  FilePathGlob FilePathRelative+    (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}"++  parseFail "{"+  parseFail "}"+  parseFail ","+  parseFail "{"+  parseFail "{{}"+  parseFail "{}"+  parseFail "{,}"+  parseFail "{foo,}"+  parseFail "{,foo}"++  return ()++testparse :: String -> IO FilePathGlob+testparse s =+    case eitherParsec s of+      Right p  -> return p+      Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err)++parseFail :: String -> Assertion+parseFail s =+    case eitherParsec s :: Either String FilePathGlob of+      Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)+      Left _  -> return ()
+ tests/UnitTests/Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,79 @@+module UnitTests.Distribution.Client.IndexUtils where++import Distribution.Client.IndexUtils+import qualified Distribution.Compat.NonEmptySet as NES+import Distribution.Simple.Utils (toUTF8LBS)+import Distribution.Version+import Distribution.Types.Dependency+import Distribution.Types.PackageName+import Distribution.Types.LibraryName+++import Test.Tasty+import Test.Tasty.HUnit++tests :: [TestTree]+tests =+    [ simpleVersionsParserTests+    ]++simpleVersionsParserTests :: TestTree+simpleVersionsParserTests = testGroup "Simple preferred-versions Parser Tests"+    [ testCase "simple deprecation dependency" $ do+        let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0")+        prefs @?=+            [ Right+                (Dependency+                    (mkPackageName "binary")+                    (unionVersionRanges+                        (earlierVersion $ mkVersion [0,9,0,0])+                        (laterVersion $ mkVersion [0,9,0,0])+                    )+                    (NES.singleton LMainLibName)+                )+            ]+    , testCase "multiple deprecation dependency" $ do+        let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1")+        prefs @?=+            [ Right+                (Dependency+                    (mkPackageName "binary")+                    (unionVersionRanges+                        (earlierVersion $ mkVersion [0,9,0,0])+                        (laterVersion $ mkVersion [0,9,0,0])+                    )+                    (NES.singleton LMainLibName)+                )+            , Right+                (Dependency+                    (mkPackageName "containers")+                    (thisVersion $ mkVersion [0,6,4,1])+                    (NES.singleton LMainLibName)+                )+            ]+    , testCase "unparsable dependency" $ do+        let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0")+        prefs @?=+            [ Left binaryDepParseError+            ]+    , testCase "partial parse" $ do+        let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1")+        prefs @?=+            [ Left binaryDepParseError+            , Right+                (Dependency+                    (mkPackageName "containers")+                    (thisVersion $ mkVersion [0,6,4,1])+                    (NES.singleton LMainLibName)+                )+            ]+    ]+    where+        binaryDepParseError = PreferredVersionsParseError+            { preferredVersionsParsecError = mconcat+                [ "\"<eitherParsec>\" (line 1, column 8):\n"+                , "unexpected '0'\n"+                , "expecting space, white space, opening paren, operator or end of input"+                ]+            , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"+            }
+ tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,61 @@+module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where++import Distribution.Parsec (simpleParsec)+import Distribution.Pretty (prettyShow)+import Data.Time+import Data.Time.Clock.POSIX++import Distribution.Client.IndexUtils.Timestamp++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+    [ testProperty "Timestamp1" prop_timestamp1+    , testProperty "Timestamp2" prop_timestamp2+    , testProperty "Timestamp3" prop_timestamp3+    , testProperty "Timestamp4" prop_timestamp4+    , testProperty "Timestamp5" prop_timestamp5+    ]++-- test unixtime format parsing+prop_timestamp1 :: NonNegative Int -> Bool+prop_timestamp1 (NonNegative t0) = Just t == simpleParsec ('@':show t0)+  where+    t = toEnum t0 :: Timestamp++-- test prettyShow/simpleParse roundtrip+prop_timestamp2 :: Int -> Bool+prop_timestamp2 t0+  | t /= nullTimestamp  = simpleParsec (prettyShow t) == Just t+  | otherwise           = prettyShow t == ""+  where+    t = toEnum t0 :: Timestamp++-- test prettyShow against reference impl+prop_timestamp3 :: Int -> Bool+prop_timestamp3 t0+  | t /= nullTimestamp  = refDisp t == prettyShow t+  | otherwise           = prettyShow t == ""+  where+    t = toEnum t0 :: Timestamp++    refDisp = maybe undefined (formatTime undefined "%FT%TZ")+              . timestampToUTCTime++-- test utcTimeToTimestamp/timestampToUTCTime roundtrip+prop_timestamp4 :: Int -> Bool+prop_timestamp4 t0+  | t /= nullTimestamp  = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t+  | otherwise           = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp++prop_timestamp5 :: Int -> Bool+prop_timestamp5 t0+  | t /= nullTimestamp = timestampToUTCTime t == Just ut+  | otherwise          = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp+    ut = posixSecondsToUTCTime (fromIntegral t0)
+ tests/UnitTests/Distribution/Client/Init.hs view
@@ -0,0 +1,51 @@+module UnitTests.Distribution.Client.Init+( tests+) where++import Test.Tasty++import qualified UnitTests.Distribution.Client.Init.Interactive    as Interactive+import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive+import qualified UnitTests.Distribution.Client.Init.Golden         as Golden+import qualified UnitTests.Distribution.Client.Init.Simple         as Simple+import qualified UnitTests.Distribution.Client.Init.FileCreators   as FileCreators++import UnitTests.Distribution.Client.Init.Utils++import Distribution.Client.Config+import Distribution.Client.IndexUtils+import Distribution.Client.Init.Types+import Distribution.Client.Sandbox+import Distribution.Client.Setup+import Distribution.Verbosity+++tests :: IO [TestTree]+tests = do+    confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags++    let confFlags'   = savedConfigureFlags confFlags `mappend` compFlags+        initFlags'   = savedInitFlags      confFlags `mappend` emptyFlags+        globalFlags' = savedGlobalFlags    confFlags `mappend` defaultGlobalFlags++    (comp, _, progdb) <- configCompilerAux' confFlags'++    withRepoContext v globalFlags' $ \repoCtx -> do+      let pkgDb = configPackageDB' confFlags'++      pkgIx <- getInstalledPackages v comp pkgDb progdb+      srcDb <- getSourcePackages v repoCtx++      return+         [ Interactive.tests v initFlags' pkgIx srcDb+         , NonInteractive.tests v initFlags' comp pkgIx srcDb+         , Golden.tests v initFlags' pkgIx srcDb+         , Simple.tests v initFlags' pkgIx srcDb+         , FileCreators.tests v initFlags' comp pkgIx srcDb+         ]+  where+    v :: Verbosity+    v = normal++    compFlags :: ConfigFlags+    compFlags = mempty { configHcPath = initHcPath emptyFlags }
+ tests/UnitTests/Distribution/Client/Init/FileCreators.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module UnitTests.Distribution.Client.Init.FileCreators+  ( tests+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import UnitTests.Distribution.Client.Init.Utils++import Distribution.Client.Init.FileCreators+import Distribution.Client.Init.NonInteractive.Command+import Distribution.Client.Init.Types+import Distribution.Client.Types+import Distribution.Simple+import Distribution.Simple.Flag+import Distribution.Simple.PackageIndex+import Distribution.Verbosity++tests +    :: Verbosity+    -> InitFlags+    -> Compiler+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+tests _v _initFlags comp pkgIx srcDb =+  testGroup "Distribution.Client.Init.FileCreators"+    [ testCase "Check . as source directory" $ do+        let dummyFlags' = dummyFlags+              { packageType = Flag LibraryAndExecutable+              , minimal = Flag False+              , overwrite = Flag False+              , packageDir = Flag "/home/test/test-package"+              , extraDoc = Flag ["CHANGELOG.md"]+              , exposedModules = Flag []+              , otherModules = Flag []+              , otherExts = Flag []+              , buildTools = Flag []+              , mainIs = Flag "quxApp/Main.hs"+              , dependencies = Flag []+              , sourceDirs = Flag ["."]+              }+            inputs =+              -- createProject stuff+              [ "True"+              , "[\"quxTest/Main.hs\"]"+              -- writeProject stuff+              -- writeLicense+              , "2021"+              -- writeFileSafe+              , "True"+              -- findNewPath+              , "False"+              -- writeChangeLog+              -- writeFileSafe+              , "False"+              -- prepareLibTarget+              -- writeDirectoriesSafe+              , "True"+              -- findNewPath+              , "False"+              -- prepareExeTarget+              -- writeDirectoriesSafe+              , "False"+              -- writeFileSafe+              , "False"+              -- prepareTestTarget+              -- writeDirectoriesSafe+              , "False"+              -- writeFileSafe+              , "False"+              -- writeCabalFile+              -- writeFileSafe+              , "False"+              ]++        case flip _runPrompt inputs $ do+            projSettings <- createProject comp silent pkgIx srcDb dummyFlags'+            writeProject projSettings of++          Left (BreakException ex) -> assertFailure $ show ex+          Right _ -> return ()+        ++    ]
+ tests/UnitTests/Distribution/Client/Init/Golden.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+module UnitTests.Distribution.Client.Init.Golden+( tests+) where+++import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit++import qualified Data.ByteString.Lazy.Char8 as BS8+import Data.List.NonEmpty (fromList)+import Data.List.NonEmpty as NEL (NonEmpty, drop)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup ((<>))+#endif++import Distribution.Client.Init.Types+import Distribution.Simple.PackageIndex hiding (fromList)+import Distribution.Verbosity+import Distribution.Client.Types.SourcePackageDb+import Distribution.Client.Init.Interactive.Command+import Distribution.Client.Init.Format+import Distribution.Fields.Pretty+import Distribution.Types.PackageName (PackageName)+import Distribution.Client.Init.FlagExtractors+import Distribution.Simple.Flag+import Distribution.CabalSpecVersion++import System.FilePath++import UnitTests.Distribution.Client.Init.Utils+import Distribution.Client.Init.Defaults++-- -------------------------------------------------------------------- --+-- golden test suite++-- | Golden executable tests.+--+-- We test target generation against a golden file in @tests/fixtures/init/@ for+-- executables, libraries, and test targets with the following:+--+-- * Empty flags, non-simple target gen, no special options+-- * Empty flags, simple target gen, no special options+-- * Empty flags, non-simple target gen, with generated comments (no minimal setting)+-- * Empty flags, non-simple target gen, with minimal setting (no generated comments)+-- * Empty flags, non-simple target gen, minimal and generated comments set.+--+-- Additionally, we test whole @.cabal@ file generation for every combination+-- of library, lib + tests, exe, exe + tests, exe + lib, exe + lib + tests+-- and so on against the same options.+--+tests+    :: Verbosity+    -> InitFlags+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+tests v initFlags pkgIx srcDb = testGroup "golden"+    [ goldenLibTests v pkgIx pkgDir pkgName+    , goldenExeTests v pkgIx pkgDir pkgName+    , goldenTestTests v pkgIx pkgDir pkgName+    , goldenPkgDescTests v srcDb pkgDir pkgName+    , goldenCabalTests v pkgIx srcDb+    ]+  where+    pkgDir = evalPrompt (getPackageDir initFlags)+      $ fromList ["."]+    pkgName = evalPrompt (packageNamePrompt srcDb initFlags)+      $ fromList ["test-package", "y"]++goldenPkgDescTests+    :: Verbosity+    -> SourcePackageDb+    -> FilePath+    -> PackageName+    -> TestTree+goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golden tests"+    [ goldenVsString "Empty flags, non-simple, no comments"+      (goldenPkgDesc "pkg.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runPkgDesc opts emptyFlags pkgArgs++    , goldenVsString "Empty flags, non-simple, with comments"+      (goldenPkgDesc "pkg-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runPkgDesc opts emptyFlags pkgArgs++    , goldenVsString "Dummy flags, with comments"+      (goldenPkgDesc "pkg-with-flags.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runPkgDesc opts dummyFlags pkgArgs++    , goldenVsString "Dummy flags, old cabal version, with comments"+      (goldenPkgDesc "pkg-old-cabal-with-flags.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV2_0}) pkgArgs+    ]+  where+    runPkgDesc opts flags args = do+      case _runPrompt (genPkgDescription flags srcDb) args of+        Left e -> assertFailure $ show e+        Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg++goldenExeTests+    :: Verbosity+    -> InstalledPackageIndex+    -> FilePath+    -> PackageName+    -> TestTree+goldenExeTests v pkgIx pkgDir pkgName = testGroup "exe golden tests"+    [ goldenVsString "Empty flags, not simple, no options, no comments"+      (goldenExe "exe-no-comments.golden") $+        let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion+        in runGoldenExe opts exeArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with comments + no minimal"+      (goldenExe "exe-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion+        in runGoldenExe opts exeArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + no comments"+      (goldenExe "exe-minimal-no-comments.golden") $+        let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion+        in runGoldenExe opts exeArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + comments"+      (goldenExe "exe-simple-minimal-with-comments.golden") $+        let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion+        in runGoldenExe opts exeArgs emptyFlags++    , goldenVsString "Build tools flag, not simple, with comments + no minimal"+      (goldenExe "exe-build-tools-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion+        in runGoldenExe opts exeArgs (emptyFlags {buildTools = Flag ["happy"]})+    ]+  where+    runGoldenExe opts args flags =+      case _runPrompt (genExeTarget flags pkgIx) args of+        Right (t, _) -> mkStanza [mkExeStanza opts $ t {_exeDependencies = mangleBaseDep t _exeDependencies}]+        Left e -> assertFailure $ show e++goldenLibTests+    :: Verbosity+    -> InstalledPackageIndex+    -> FilePath+    -> PackageName+    -> TestTree+goldenLibTests v pkgIx pkgDir pkgName = testGroup "lib golden tests"+    [ goldenVsString "Empty flags, not simple, no options, no comments"+      (goldenLib "lib-no-comments.golden") $+        let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs emptyFlags++    , goldenVsString "Empty flags, simple, no options, no comments"+      (goldenLib "lib-simple-no-comments.golden") $+        let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with comments + no minimal"+      (goldenLib "lib-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + no comments"+      (goldenLib "lib-minimal-no-comments.golden") $+        let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + comments"+      (goldenLib "lib-simple-minimal-with-comments.golden") $+        let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs emptyFlags++    , goldenVsString "Build tools flag, not simple, with comments + no minimal"+      (goldenLib "lib-build-tools-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenLib opts libArgs (emptyFlags {buildTools = Flag ["happy"]})+    ]+  where+    runGoldenLib opts args flags =+      case _runPrompt (genLibTarget flags pkgIx) args of+        Right (t, _) -> mkStanza [mkLibStanza opts $ t {_libDependencies = mangleBaseDep t _libDependencies}]+        Left e -> assertFailure $ show e++goldenTestTests+    :: Verbosity+    -> InstalledPackageIndex+    -> FilePath+    -> PackageName+    -> TestTree+goldenTestTests v pkgIx pkgDir pkgName = testGroup "test golden tests"+    [ goldenVsString "Empty flags, not simple, no options, no comments"+      (goldenTest "test-no-comments.golden") $+        let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with comments + no minimal"+      (goldenTest "test-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + no comments"+      (goldenTest "test-minimal-no-comments.golden") $+        let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags++    , goldenVsString "Empty flags, not simple, with minimal + comments"+      (goldenTest "test-simple-minimal-with-comments.golden") $+        let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags++    , goldenVsString "Build tools flag, not simple, with comments + no minimal"+      (goldenTest "test-build-tools-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion+        in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]})+    +    , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments"+      (goldenTest "standalone-test-no-comments.golden") $+        let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags++    , goldenVsString "Standalone tests, empty flags, not simple, with comments + no minimal"+      (goldenTest "standalone-test-with-comments.golden") $+        let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion+        in runGoldenTest opts testArgs emptyFlags+    ]+  where+    runGoldenTest opts args flags =+      case _runPrompt (genTestTarget flags pkgIx) args of+        Left e -> assertFailure $ show e+        Right (Nothing, _) -> assertFailure+          "goldenTestTests: Tests not enabled."+        Right (Just t, _) -> mkStanza [mkTestStanza opts $ t {_testDependencies = mangleBaseDep t _testDependencies}]++-- | Full cabal file golden tests+goldenCabalTests+    :: Verbosity+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+goldenCabalTests v pkgIx srcDb = testGroup ".cabal file golden tests"+    [ goldenVsString "Library and executable, empty flags, not simple, with comments + no minimal"+      (goldenCabal "cabal-lib-and-exe-with-comments.golden") $+        runGoldenTest (fullProjArgs "Y") emptyFlags++    , goldenVsString "Library and executable, empty flags, not simple, no comments + no minimal"+      (goldenCabal "cabal-lib-and-exe-no-comments.golden") $+        runGoldenTest (fullProjArgs "N") emptyFlags++    , goldenVsString "Library, empty flags, not simple, with comments + no minimal"+      (goldenCabal "cabal-lib-with-comments.golden") $+        runGoldenTest (libProjArgs "Y") emptyFlags++    , goldenVsString "Library, empty flags, not simple, no comments + no minimal"+      (goldenCabal "cabal-lib-no-comments.golden") $+        runGoldenTest (libProjArgs "N") emptyFlags+    +    , goldenVsString "Test suite, empty flags, not simple, with comments + no minimal"+      (goldenCabal "cabal-test-suite-with-comments.golden") $+        runGoldenTest (testProjArgs "Y") emptyFlags++    , goldenVsString "Test suite, empty flags, not simple, no comments + no minimal"+      (goldenCabal "cabal-test-suite-no-comments.golden") $+        runGoldenTest (testProjArgs "N") emptyFlags+    ]+  where+    runGoldenTest args flags =+      case _runPrompt (createProject v pkgIx srcDb flags) args of+        Left e -> assertFailure $ show e++        (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do+          let pkgFields = mkPkgDescription opts pkgDesc+              commonStanza = mkCommonStanza opts+              libStanza  = mkLibStanza  opts $ libTarget {_libDependencies  = mangleBaseDep libTarget  _libDependencies}+              exeStanza  = mkExeStanza  opts $ exeTarget {_exeDependencies  = mangleBaseDep exeTarget  _exeDependencies}+              testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}++          mkStanza $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]++        (Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do+          let pkgFields = mkPkgDescription opts pkgDesc+              commonStanza = mkCommonStanza opts+              libStanza  = mkLibStanza  opts $ libTarget  {_libDependencies  = mangleBaseDep libTarget  _libDependencies}+              testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}++          mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza]+        +        (Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do+          let pkgFields = mkPkgDescription opts pkgDesc+              commonStanza = mkCommonStanza opts+              testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}+          +          mkStanza $ pkgFields ++ [commonStanza, testStanza]++        (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $+          show l ++ "\n" ++ show e ++ "\n" ++ show t+++-- -------------------------------------------------------------------- --+-- utils++mkStanza :: [PrettyField FieldAnnotation] -> IO BS8.ByteString+mkStanza fields = return . BS8.pack $ showFields'+    annCommentLines postProcessFieldLines+    4 fields++golden :: FilePath+golden = "tests" </> "fixtures" </> "init" </> "golden"++goldenExe :: FilePath -> FilePath+goldenExe file = golden </> "exe" </> file++goldenTest :: FilePath -> FilePath+goldenTest file = golden </> "test" </> file++goldenLib :: FilePath -> FilePath+goldenLib file = golden </> "lib" </> file++goldenCabal :: FilePath -> FilePath+goldenCabal file = golden </> "cabal" </> file++goldenPkgDesc :: FilePath -> FilePath+goldenPkgDesc file = golden </> "pkg-desc" </> file++libArgs :: NonEmpty String+libArgs = fromList ["1", "2"]++exeArgs :: NonEmpty String+exeArgs = fromList ["1", "2", "1"]++testArgs :: NonEmpty String+testArgs = fromList ["y", "1", "test", "1"]++pkgArgs :: NonEmpty String+pkgArgs = fromList+    [ "5"+    , "foo-package"+    , "y"+    , "0.1.0.0"+    , "2"+    , "git username"+    , "foo-kmett"+    , "git email"+    , "foo-kmett@kmett.kmett"+    , "home"+    , "synopsis"+    , "4"+    ]++testProjArgs :: String -> NonEmpty String+testProjArgs comments = fromList ["4", "n", "foo-package"]+  <> pkgArgs+  <> fromList (NEL.drop 1 testArgs)+  <> fromList [comments]++libProjArgs :: String -> NonEmpty String+libProjArgs comments = fromList ["1", "n", "foo-package"]+  <> pkgArgs+  <> libArgs+  <> testArgs+  <> fromList [comments]++fullProjArgs :: String -> NonEmpty String+fullProjArgs comments = fromList ["3", "n", "foo-package"]+  <> pkgArgs+  <> libArgs+  <> exeArgs+  <> testArgs+  <> fromList [comments]
+ tests/UnitTests/Distribution/Client/Init/Interactive.hs view
@@ -0,0 +1,1026 @@+module UnitTests.Distribution.Client.Init.Interactive+( tests+) where+++import Prelude as P+import Test.Tasty+import Test.Tasty.HUnit++import Distribution.Client.Init.Defaults+import Distribution.Client.Init.Interactive.Command+import Distribution.Client.Init.Types++import qualified Distribution.SPDX as SPDX++import Data.List.NonEmpty hiding (zip)+import Distribution.Client.Types+import Distribution.Simple.PackageIndex hiding (fromList)+import Distribution.Types.PackageName+import Distribution.Types.Version+import Distribution.Verbosity++import Language.Haskell.Extension++import UnitTests.Distribution.Client.Init.Utils+import Distribution.Client.Init.FlagExtractors+import Distribution.Simple.Setup+import Distribution.CabalSpecVersion+import qualified Data.Set as Set+import Distribution.FieldGrammar.Newtypes+++-- -------------------------------------------------------------------- --+-- Init Test main++tests+    :: Verbosity+    -> InitFlags+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+tests _v initFlags pkgIx srcDb =+  testGroup "Distribution.Client.Init.Interactive.Command.hs"+    [ createProjectTest pkgIx srcDb+    , fileCreatorTests pkgIx srcDb pkgName+    , interactiveTests srcDb+    ]+  where+    pkgName = evalPrompt (packageNamePrompt srcDb initFlags) $+        fromList ["test-package", "y"]++    -- pkgNm  = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"]++createProjectTest+  :: InstalledPackageIndex+  -> SourcePackageDb+  -> TestTree+createProjectTest pkgIx srcDb = testGroup "createProject tests"+  [ testGroup "with flags"+    [ testCase "Check the interactive workflow" $ do+        let dummyFlags' = dummyFlags+              { packageType = Flag LibraryAndExecutable+              , minimal = Flag False+              , overwrite = Flag False+              , packageDir = Flag "/home/test/test-package"+              , extraSrc = NoFlag+              , exposedModules = Flag []+              , otherModules = Flag []+              , otherExts = Flag []+              , buildTools = Flag []+              , mainIs = Flag "quxApp/Main.hs"+              , dependencies = Flag []+              }++        case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of+          Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= True+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "QuxPackage"++            _pkgCabalVersion  desc @?= CabalSpecV2_2+            _pkgName          desc @?= mkPackageName "QuxPackage"+            _pkgVersion       desc @?= mkVersion [4,2,6]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "We are Qux, and this is our package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["quxSrc"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?= []+            _libBuildTools     lib @?= []++            _exeMainIs          exe @?= HsFilePath "quxApp/Main.hs" Standard+            _exeApplicationDirs exe @?= ["quxApp"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++            _testMainIs       test @?= HsFilePath "quxTest/Main.hs" Standard+            _testDirs         test @?= ["quxTest"]+            _testLanguage     test @?= Haskell98+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e+    ]++  , testGroup "with tests"+    [ testCase "Check the interactive library and executable workflow" $ do+        let inputs = fromList+              -- package type+              [ "3"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- library target+              -- source dir+              , "1"+              -- language+              , "2"+              -- executable target+              -- main file+              , "1"+              -- application dir+              , "2"+              -- language+              , "2"+              -- test target+              , "y"+              -- main file+              , "1"+              -- test dir+              , "test"+              -- language+              , "1"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= []++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["exe"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++            _testMainIs       test @?= HsFilePath "Main.hs" Standard+            _testDirs         test @?= ["test"]+            _testLanguage     test @?= Haskell2010+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the interactive library workflow" $ do+        let inputs = fromList+              -- package type+              [  "1"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- library target+              -- source dir+              , "1"+              -- language+              , "2"+              -- test target+              , "y"+              -- main file+              , "1"+              -- test dir+              , "test"+              -- language+              , "1"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Library+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= []++            _testMainIs       test @?= HsFilePath "Main.hs" Standard+            _testDirs         test @?= ["test"]+            _testLanguage     test @?= Haskell2010+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?= Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e+    +    , testCase "Check the interactive library workflow" $ do+        let inputs = fromList+              -- package type+              [  "4"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- test target+              -- main file+              , "1"+              -- test dir+              , "test"+              -- language+              , "1"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= TestSuite+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _testMainIs       test @?= HsFilePath "Main.hs" Standard+            _testDirs         test @?= ["test"]+            _testLanguage     test @?= Haskell2010+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?= Nothing+            exe  @?= Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e+    ]+  , testGroup "without tests"+    [ testCase "Check the interactive library and executable workflow" $ do+        let inputs = fromList+              -- package type+              [ "3"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- library target+              -- source dir+              , "1"+              -- language+              , "2"+              -- executable target+              -- main file+              , "1"+              -- application dir+              , "2"+              -- language+              , "2"+              -- test suite+              , "n"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= []++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["exe"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the interactive library workflow" $ do+        let inputs = fromList+              -- package type+              [ "1"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- library target+              -- source dir+              , "1"+              -- language+              , "2"+              -- test suite+              , "n"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Library+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?= Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the interactive library workflow - cabal < 1.18" $ do+        let inputs = fromList+              -- package type+              [ "1"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- library target+              -- source dir+              , "1"+              -- language+              , "2"+              -- test suite+              , "n"+              -- comments+              , "y"+              ]++            flags = emptyFlags+              { cabalVersion = Flag CabalSpecV1_10+              , extraDoc = Flag [defaultChangelog]+              , extraSrc = Flag ["README.md"]+              }++        case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of+          Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Library+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV1_10+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"]+            _pkgExtraDocFiles desc @?= Nothing++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule :| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?= Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the interactive executable workflow" $ do+        let inputs = fromList+              -- package type+              [ "2"+              -- overwrite+              , "n"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "4"+              -- package name+              , "test-package"+              , "test-package"+              -- version+              , "3.1.2.3"+              -- license+              , "3"+              -- author+              , "git username"+              , "Foobar"+              -- email+              , "git email"+              , "foobar@qux.com"+              -- homepage+              , "qux.com"+              -- synopsis+              , "Qux's package"+              -- category+              , "3"+              -- executable target+              -- main file+              , "1"+              -- application dir+              , "2"+              -- language+              , "2"+              -- comments+              , "y"+              ]++        case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Executable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV2_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [3,1,2,3]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "Qux's package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["exe"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?= Nothing+            exe  @?! Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e+    ]+  ]++fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> PackageName -> TestTree+fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators"+  [ testGroup "genPkgDescription"+    [ testCase "Check common package flags workflow" $ do+        let inputs = fromList+              [ "1"               -- pick the first cabal version in the list+              , "my-test-package" -- package name+              , "y"               -- "yes to prompt internal to package name"+              , "0.2.0.1"         -- package version+              , "2"               -- pick the second license in the list+              , "git username"    -- name guessed by calling "git config user.name"+              , "Foobar"          -- author name+              , "git email"       -- email guessed by calling "git config user.email"+              , "foobar@qux.com"  -- maintainer email+              , "qux.com"         -- package homepage+              , "Qux's package"   -- package synopsis+              , "3"               -- pick the third category in the list+              ]+        runGenTest inputs $ genPkgDescription emptyFlags srcDb+    ]+  , testGroup "genLibTarget"+    [ testCase "Check library package flags workflow" $ do+        let inputs = fromList+              [ "1"               -- pick the first source directory in the list+              , "2"               -- pick the second language in the list+              ]++        runGenTest inputs $ genLibTarget emptyFlags pkgIx+    ]+  , testGroup "genExeTarget"+    [ testCase "Check executable package flags workflow" $ do+        let inputs = fromList+              [ "1"               -- pick the first main file option in the list+              , "2"               -- pick the second application directory in the list+              , "1"               -- pick the first language in the list+              ]++        runGenTest inputs $ genExeTarget emptyFlags pkgIx+    ]+  , testGroup "genTestTarget"+    [ testCase "Check test package flags workflow" $ do+        let inputs = fromList+              [ "y"               -- say yes to tests+              , "1"               -- pick the first main file option in the list+              , "test"            -- package test dir+              , "1"               -- pick the first language in the list+              ]++        runGenTest inputs $ genTestTarget emptyFlags pkgIx+    ]+  ]+  where+    runGenTest inputs go = case _runPrompt go inputs of+      Left e -> assertFailure $ show e+      Right{} -> return ()++interactiveTests :: SourcePackageDb -> TestTree+interactiveTests srcDb = testGroup "Check top level getter functions"+  [ testGroup "Simple prompt tests"+    [ testGroup "Check packageNamePrompt output"+      [ testSimplePrompt "New package name 1"+          (packageNamePrompt srcDb) (mkPackageName "test-package")+          [ "test-package"+          , "test-package"+          ]+      , testSimplePrompt "New package name 2"+          (packageNamePrompt srcDb) (mkPackageName "test-package")+          [ "test-package"+          , ""+          ]+      , testSimplePrompt "Existing package name 1"+          (packageNamePrompt srcDb) (mkPackageName "test-package")+          [ "test-package"+          , "cabal-install"+          , "y"+          , "test-package"+          ]+      , testSimplePrompt "Existing package name 2"+          (packageNamePrompt srcDb) (mkPackageName "cabal-install")+          [ "test-package"+          , "cabal-install"+          , "n"+          ]+      ]+    , testGroup "Check mainFilePrompt output"+      [ testSimplePrompt "New valid main file"+          mainFilePrompt defaultMainIs+          [ "1"+          ]+      , testSimplePrompt "New valid other main file"+          mainFilePrompt (HsFilePath "Main.hs" Standard)+          [ "3"+          , "Main.hs"+          ]+      , testSimplePrompt "Invalid other main file"+          mainFilePrompt (HsFilePath "Main.lhs" Literate)+          [ "3"+          , "Yoink.jl"+          , "2"+          ]+      ]+    , testGroup "Check versionPrompt output"+      [ testSimplePrompt "Proper PVP"+          versionPrompt (mkVersion [0,3,1,0])+          [ "0.3.1.0"+          ]+      , testSimplePrompt "No PVP"+          versionPrompt (mkVersion [0,3,1,0])+          [ "yee-haw"+          , "0.3.1.0"+          ]+      ]+    , testGroup "Check synopsisPrompt output"+        [ testSimplePrompt "1" synopsisPrompt+            "We are Qux, and this is our package" ["We are Qux, and this is our package"]+        , testSimplePrompt "2" synopsisPrompt+            "Resistance is futile, you will be assimilated" ["Resistance is futile, you will be assimilated"]+        ]+    , testSimplePrompt "Check authorPrompt output (name supplied by the user)" authorPrompt+        "Foobar" ["git username", "Foobar"]+    , testSimplePrompt "Check authorPrompt output (name guessed from git config)" authorPrompt+        "git username" ["git username", ""]+    , testSimplePrompt "Check emailPrompt output (email supplied by the user)" emailPrompt+        "foobar@qux.com" ["git email", "foobar@qux.com"]+    , testSimplePrompt "Check emailPrompt output (email guessed from git config)" emailPrompt+        "git@email" ["git@email", ""]+    , testSimplePrompt "Check homepagePrompt output" homepagePrompt+        "qux.com" ["qux.com"]+    , testSimplePrompt "Check testDirsPrompt output" testDirsPrompt+        ["quxTest"] ["quxTest"]+      -- this tests 4) other, and can be used to model more inputs in case of failure+    , testSimplePrompt "Check srcDirsPrompt output" srcDirsPrompt+        ["app"] ["4", "app"]+    ]+  , testGroup "Numbered prompt tests"+    [ testGroup "Check categoryPrompt output"+      [ testNumberedPrompt "Category indices" categoryPrompt+          defaultCategories+      , testSimplePrompt "Other category"+          categoryPrompt "Unlisted"+          [ show $ P.length defaultCategories + 1+          , "Unlisted"+          ]+      , testSimplePrompt "No category"+          categoryPrompt ""+          [ ""+          ]+      ]+    , testGroup "Check licensePrompt output" $ let other = show (1 + P.length defaultLicenseIds) in+        [ testNumberedPrompt "License indices" licensePrompt $+            fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds+        , testSimplePrompt "Other license 1"+            licensePrompt (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0)+            [ other+            , "CC-BY-NC-ND-4.0"+            ]+        , testSimplePrompt "Other license 2"+            licensePrompt (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0)+            [ other+            , "D-FSL-1.0"+            ]+        , testSimplePrompt "Other license 3"+            licensePrompt (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0)+            [ other+            , "NPOSL-3.0"+            ]+        , testSimplePrompt "Invalid license"+            licensePrompt (SpecLicense $ Left SPDX.NONE)+            [ other+            , "yay"+            , other+            , "NONE"+            ]+        , testPromptBreak "Invalid index"+            licensePrompt+            [ "42"+            ]+        ]+    , testGroup "Check languagePrompt output"+        [ testNumberedPrompt "Language indices" (`languagePrompt` "test")+            [Haskell2010, Haskell98, GHC2021]+        , testSimplePrompt "Other language"+            (`languagePrompt` "test") (UnknownLanguage "Haskell2022")+            [ "4"+            , "Haskell2022"+            ]+        , testSimplePrompt "Invalid language"+            (`languagePrompt` "test") Haskell2010+            [ "4"+            , "Lang_TS!"+            , "1"+            ]+        ]+    , testGroup "Check srcDirsPrompt output"+        [ testNumberedPrompt "Soruce dirs indices" srcDirsPrompt+            [[defaultSourceDir], ["lib"], ["src-lib"]]+        , testSimplePrompt "Other source dir"+            srcDirsPrompt ["src"]+            [ "4"+            , "src"+            ]+        ]+    , testGroup "Check appDirsPrompt output"+        [ testNumberedPrompt "App dirs indices" appDirsPrompt+            [[defaultApplicationDir], ["exe"], ["src-exe"]]+        , testSimplePrompt "Other app dir"+            appDirsPrompt ["app"]+            [ "4"+            , "app"+            ]+        ]+    , testNumberedPrompt "Check packageTypePrompt output" packageTypePrompt+        [Library, Executable, LibraryAndExecutable]+    , testNumberedPrompt "Check cabalVersionPrompt output" cabalVersionPrompt+        defaultCabalVersions+    ]+  , testGroup "Bool prompt tests"+    [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y"+    , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y"+    , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n"+    , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N"+    ]+  ]++++-- -------------------------------------------------------------------- --+-- Prompt test utils+++testSimplePrompt+    :: Eq a+    => Show a+    => String+    -> (InitFlags -> PurePrompt a)+    -> a+    -> [String]+    -> TestTree+testSimplePrompt label f target =+    testPrompt label f (assertFailure . show) (\(a,_) -> target @=? a)++testPromptBreak+    :: Eq a+    => Show a+    => String+    -> (InitFlags -> PurePrompt a)+    -> [String]+    -> TestTree+testPromptBreak label f =+    testPrompt label f go (assertFailure . show)+  where+    go BreakException{} =+      return ()++testPrompt+    :: Eq a+    => Show a+    => String+    -> (InitFlags -> PurePrompt a)+    -> (BreakException -> Assertion)+    -> ((a, NonEmpty String) -> Assertion)+    -> [String]+    -> TestTree+testPrompt label f g h input = testCase label $+    case (_runPrompt $ f emptyFlags) (fromList input) of+      Left x -> g x -- :: BreakException+      Right x -> h x -- :: (a, other inputs)++testNumberedPrompt :: (Eq a, Show a) => String -> (InitFlags -> PurePrompt a) -> [a] -> TestTree+testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexed1+  where+    indexed1 = zip [1 :: Int ..]+    mkLabel a n = "testing index "+      ++ show n+      ++ ") with: "+      ++ show a++    go (n, a) =+      testSimplePrompt (mkLabel a n) act a [show n]+    goBreak =+      [ testPromptBreak "testing index -1" act ["-1"]+      , testPromptBreak "testing index 1000" act ["1000"]+      ]++testBoolPrompt+    :: String+    -> (InitFlags -> PurePrompt Bool)+    -> Bool+    -> String+    -> TestTree+testBoolPrompt label act target b =+    testSimplePrompt label act target [b]
+ tests/UnitTests/Distribution/Client/Init/NonInteractive.hs view
@@ -0,0 +1,1267 @@+module UnitTests.Distribution.Client.Init.NonInteractive+  ( tests+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import UnitTests.Distribution.Client.Init.Utils++import qualified Data.List.NonEmpty as NEL+import qualified Distribution.SPDX  as SPDX++import Distribution.Client.Init.Defaults+import Distribution.Client.Init.NonInteractive.Command+import Distribution.Client.Init.Types+import Distribution.Client.Types+import Distribution.Simple+import Distribution.Simple.PackageIndex+import Distribution.Verbosity+import Distribution.CabalSpecVersion+import Distribution.ModuleName (fromString)+import Distribution.Simple.Flag+import Data.List (foldl')+import qualified Data.Set as Set+import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep)+import Distribution.FieldGrammar.Newtypes++tests+    :: Verbosity+    -> InitFlags+    -> Compiler+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+tests _v _initFlags comp pkgIx srcDb =+  testGroup "Distribution.Client.Init.NonInteractive.Command"+    [ testGroup "driver function test"+      [ driverFunctionTest pkgIx srcDb comp+      ]+    , testGroup "target creator tests"+      [ fileCreatorTests pkgIx srcDb comp+      ]+    , testGroup "non-interactive tests"+      [ nonInteractiveTests pkgIx srcDb comp+      ]+    ]++driverFunctionTest+  :: InstalledPackageIndex+  -> SourcePackageDb+  -> Compiler+  -> TestTree+driverFunctionTest pkgIx srcDb comp = testGroup "createProject"+  [ testGroup "with flags"+    [ testCase "Check the non-interactive workflow 1" $ do+        let dummyFlags' = dummyFlags+              { packageType = Flag LibraryAndExecutable+              , minimal = Flag False+              , overwrite = Flag False+              , packageDir = Flag "/home/test/test-package"+              , extraDoc = Flag ["CHANGELOG.md"]+              , exposedModules = Flag []+              , otherModules = Flag []+              , otherExts = Flag []+              , buildTools = Flag []+              , mainIs = Flag "quxApp/Main.hs"+              , dependencies = Flag []+              }+            inputs = NEL.fromList+              [ "True"+              , "[\"quxTest/Main.hs\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= True+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "QuxPackage"++            _pkgCabalVersion  desc @?= CabalSpecV2_2+            _pkgName          desc @?= mkPackageName "QuxPackage"+            _pkgVersion       desc @?= mkVersion [4,2,6]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "We are Qux, and this is our package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["quxSrc"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule NEL.:| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?= []+            _libBuildTools     lib @?= []++            _exeMainIs          exe @?= HsFilePath "quxApp/Main.hs" Standard+            _exeApplicationDirs exe @?= ["quxApp"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++            _testMainIs       test @?= HsFilePath "quxTest/Main.hs" Standard+            _testDirs         test @?= ["quxTest"]+            _testLanguage     test @?= Haskell98+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++            assertBool "The library should be a dependency of the executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe+            assertBool "The library should be a dependency of the test executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the non-interactive workflow 2" $ do+        let dummyFlags' = dummyFlags+              { packageType = Flag LibraryAndExecutable+              , minimal = Flag False+              , overwrite = Flag False+              , packageDir = Flag "/home/test/test-package"+              , extraSrc = Flag []+              , exposedModules = Flag []+              , otherModules = NoFlag+              , otherExts = Flag []+              , buildTools = Flag []+              , mainIs = Flag "quxApp/Main.hs"+              , dependencies = Flag []+              }+            inputs = NEL.fromList+              -- extra sources+              [ "[\"CHANGELOG.md\"]"+              -- lib other modules+              , "False"+              -- exe other modules+              , "False"+              -- test main file+              , "True"+              , "[\"quxTest/Main.hs\"]"+              -- test other modules+              , "False"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= True+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "QuxPackage"++            _pkgCabalVersion  desc @?= CabalSpecV2_2+            _pkgName          desc @?= mkPackageName "QuxPackage"+            _pkgVersion       desc @?= mkVersion [4,2,6]+            _pkgLicense       desc @?! (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= "qux.com"+            _pkgSynopsis      desc @?= "We are Qux, and this is our package"+            _pkgCategory      desc @?= "Control"+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["quxSrc"]+            _libLanguage       lib @?= Haskell98+            _libExposedModules lib @?= myLibModule NEL.:| []+            _libOtherModules   lib @?= []+            _libOtherExts      lib @?= []+            _libDependencies   lib @?= []+            _libBuildTools     lib @?= []++            _exeMainIs          exe @?= HsFilePath "quxApp/Main.hs" Standard+            _exeApplicationDirs exe @?= ["quxApp"]+            _exeLanguage        exe @?= Haskell98+            _exeOtherModules    exe @?= []+            _exeOtherExts       exe @?= []+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= []++            _testMainIs       test @?= HsFilePath "quxTest/Main.hs" Standard+            _testDirs         test @?= ["quxTest"]+            _testLanguage     test @?= Haskell98+            _testOtherModules test @?= []+            _testOtherExts    test @?= []+            _testDependencies test @?! []+            _testBuildTools   test @?= []++            assertBool "The library should be a dependency of the executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe+            assertBool "The library should be a dependency of the test executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e+    ]+  , testGroup "with tests"+    [ testCase "Check the non-interactive library and executable workflow" $ do+        let inputs = NEL.fromList+              -- package dir+              [ "test-package"+              -- package description+              -- cabal version+              , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , ""+              , "Foobar"+              -- author email+              , ""+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              -- library target+              -- source dirs+              , "src"+              , "True"+              -- exposed modules+              , "src"+              , "True"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other modules+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "module Baz.Internal where"+              -- other extensions+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"src/Foo.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              -- executable target+              -- application dirs+              , "app"+              , "[]"+              -- main file+              , "test-package"+              , "[\"test-package/app/\"]"+              , "True"+              , "[]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"app/Foo.hs\", \"app/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"app/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              -- test target+              -- main file+              , "True"+              , "[\"test-package/test/\"]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"test/Foo.hs\", \"test/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"test/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Test.Tasty\nimport Test.Tasty.HUnit"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags +            { initializeTestSuite = Flag True+            , packageType = Flag LibraryAndExecutable+            })) inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV3_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [0,1,0,0]+            _pkgLicense       desc @?= (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= ""+            _pkgSynopsis      desc @?= ""+            _pkgCategory      desc @?= ""+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell2010+            _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])+            _libOtherModules   lib @?= map fromString ["Baz.Internal"]+            _libOtherExts      lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= [mkStringyDep "happy:happy"]++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["app"]+            _exeLanguage        exe @?= Haskell2010+            _exeOtherModules    exe @?= map fromString ["Foo", "Bar"]+            _exeOtherExts       exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= [mkStringyDep "happy:happy"]++            _testMainIs       test @?= HsFilePath "Main.hs" Standard+            _testDirs         test @?= ["test"]+            _testLanguage     test @?= Haskell2010+            _testOtherModules test @?= map fromString ["Foo", "Bar"]+            _testOtherExts    test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _testDependencies test @?! []+            _testBuildTools   test @?= [mkStringyDep "happy:happy"]++            assertBool "The library should be a dependency of the executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe+            assertBool "The library should be a dependency of the test executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the non-interactive library workflow" $ do+        let inputs = NEL.fromList+              -- package dir+              [ "test-package"+              -- package description+              -- cabal version+              , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , "Foobar"+              -- author email+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              -- library target+              -- source dirs+              , "src"+              , "True"+              -- exposed modules+              , "src"+              , "True"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other modules+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "module Baz.Internal where"+              -- other extensions+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"src/Foo.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              -- test target+              -- main file+              , "True"+              , "[\"test-package/test/\"]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"test/Foo.hs\", \"test/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"test/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Test.Tasty\nimport Test.Tasty.HUnit"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags +            { initializeTestSuite = Flag True+            , packageType = Flag Library+            })) inputs of+          Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Library+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV3_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [0,1,0,0]+            _pkgLicense       desc @?= (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= ""+            _pkgSynopsis      desc @?= ""+            _pkgCategory      desc @?= ""+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell2010+            _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])+            _libOtherModules   lib @?= map fromString ["Baz.Internal"]+            _libOtherExts      lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= [mkStringyDep "happy:happy"]++            _testMainIs       test @?= HsFilePath "Main.hs" Standard+            _testDirs         test @?= ["test"]+            _testLanguage     test @?= Haskell2010+            _testOtherModules test @?= map fromString ["Foo", "Bar"]+            _testOtherExts    test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _testDependencies test @?! []+            _testBuildTools   test @?= [mkStringyDep "happy:happy"]+            +            assertBool "The library should be a dependency of the test executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?= Nothing+            test @?! Nothing+          Left e -> assertFailure $ show e+    ]+  , testGroup "without tests"+    [ testCase "Check the non-interactive library and executable workflow" $ do+        let inputs = NEL.fromList+              -- package type+              [ "test-package"+              , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"+              , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , ""+              , "Foobar"+              -- author email+              , ""+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              -- library target+              -- source dirs+              , "src"+              , "True"+              -- exposed modules+              , "src"+              , "True"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other modules+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "module Baz.Internal where"+              -- other extensions+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"src/Foo.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              -- executable target+              -- application dirs+              , "app"+              , "[]"+              -- main file+              , "test-package"+              , "[\"test-package/app/\"]"+              , "True"+              , "[]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"app/Foo.hs\", \"app/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"app/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= LibraryAndExecutable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV3_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [0,1,0,0]+            _pkgLicense       desc @?= (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= ""+            _pkgSynopsis      desc @?= ""+            _pkgCategory      desc @?= ""+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell2010+            _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])+            _libOtherModules   lib @?= map fromString ["Baz.Internal"]+            _libOtherExts      lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= [mkStringyDep "happy:happy"]++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["app"]+            _exeLanguage        exe @?= Haskell2010+            _exeOtherModules    exe @?= map fromString ["Foo", "Bar"]+            _exeOtherExts       exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= [mkStringyDep "happy:happy"]++            assertBool "The library should be a dependency of the executable" $+              mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?! Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the non-interactive library workflow" $ do+        let inputs = NEL.fromList+              -- package type+              [ "test-package"+              , "[\".\", \"..\", \"src/\"]"+              , "[\".\", \"..\", \"src/\"]"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , ""+              , "Foobar"+              -- author email+              , ""+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              -- library target+              -- source dirs+              , "src"+              , "True"+              -- exposed modules+              , "src"+              , "True"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other modules+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "module Baz.Internal where"+              -- other extensions+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"src/Foo.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Library+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV3_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [0,1,0,0]+            _pkgLicense       desc @?= (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= ""+            _pkgSynopsis      desc @?= ""+            _pkgCategory      desc @?= ""+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _libSourceDirs     lib @?= ["src"]+            _libLanguage       lib @?= Haskell2010+            _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])+            _libOtherModules   lib @?= map fromString ["Baz.Internal"]+            _libOtherExts      lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _libDependencies   lib @?! []+            _libBuildTools     lib @?= [mkStringyDep "happy:happy"]++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?! Nothing+            exe  @?= Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e++    , testCase "Check the non-interactive executable workflow" $ do+        let inputs = NEL.fromList+              -- package type+              [ "test-package"+              , "[\".\", \"..\", \"app/Main.hs\"]"+              , "[\".\", \"..\", \"app/Main.hs\"]"+              -- package dir+              , "test-package"+              -- package description+              -- cabal version+              , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , ""+              , "Foobar"+              -- author email+              , ""+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              -- executable target+              -- application dirs+              , "app"+              , "[]"+              -- main file+              , "test-package"+              , "[\"test-package/app/\"]"+              , "True"+              , "[]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"app/Foo.hs\", \"app/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"app/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              ]++        case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of+          Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do+            _optOverwrite  opts @?= False+            _optMinimal    opts @?= False+            _optNoComments opts @?= False+            _optVerbosity  opts @?= silent+            _optPkgDir     opts @?= "/home/test/test-package"+            _optPkgType    opts @?= Executable+            _optPkgName    opts @?= mkPackageName "test-package"++            _pkgCabalVersion  desc @?= CabalSpecV3_4+            _pkgName          desc @?= mkPackageName "test-package"+            _pkgVersion       desc @?= mkVersion [0,1,0,0]+            _pkgLicense       desc @?= (SpecLicense . Left $ SPDX.NONE)+            _pkgAuthor        desc @?= "Foobar"+            _pkgEmail         desc @?= "foobar@qux.com"+            _pkgHomePage      desc @?= ""+            _pkgSynopsis      desc @?= ""+            _pkgCategory      desc @?= ""+            _pkgExtraSrcFiles desc @?= mempty+            _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")++            _exeMainIs          exe @?= HsFilePath "Main.hs" Standard+            _exeApplicationDirs exe @?= ["app"]+            _exeLanguage        exe @?= Haskell2010+            _exeOtherModules    exe @?= map fromString ["Foo", "Bar"]+            _exeOtherExts       exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]+            _exeDependencies    exe @?! []+            _exeBuildTools      exe @?= [mkStringyDep "happy:happy"]++          Right (ProjectSettings _ _ lib exe test, _) -> do+            lib  @?= Nothing+            exe  @?! Nothing+            test @?= Nothing+          Left e -> assertFailure $ show e+    ]+  ]++fileCreatorTests+  :: InstalledPackageIndex+  -> SourcePackageDb+  -> Compiler+  -> TestTree+fileCreatorTests pkgIx srcDb comp = testGroup "generators"+  [ testGroup "genPkgDescription"+    [ testCase "Check common package flags workflow" $ do+        let inputs = NEL.fromList+              -- cabal version+              [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"+              -- package name+              , "test-package"+              , "test-package"+              -- author name+              , ""+              , "Foobar"+              -- author email+              , ""+              , "foobar@qux.com"+              -- extra source files+              , "test-package"+              , "[]"+              ]++        case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of+          Left e -> assertFailure $ show e+          Right{} -> return ()+    ]+  , testGroup "genLibTarget"+    [ testCase "Check library package flags workflow" $ do+        let inputs = NEL.fromList+              -- source dirs+              [ "src"+              , "True"+              -- exposed modules+              , "src"+              , "True"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other modules+              , "test-package"+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+              , "module Foo where"+              , "module Bar where"+              , "module Baz.Internal where"+              -- other extensions+              , "True"+              , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"src/Foo.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              ]++        case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of+          Left e -> assertFailure $ show e+          Right{} -> return ()+    ]+  , testGroup "genExeTarget"+    [ testCase "Check executable package flags workflow" $ do+        let inputs = NEL.fromList+              -- application dirs+              [ "app"+              , "[]"+              -- main file+              , "test-package"+              , "[\"test-package/app/\"]"+              , "True"+              , "[]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"app/Foo.hs\", \"app/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"app/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Control.Monad.Extra"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+              ]++        case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of+          Left e -> assertFailure $ show e+          Right{} -> return ()+    ]+  , testGroup "genTestTarget"+    [ testCase "Check test package flags workflow" $ do+        let inputs = NEL.fromList+              -- main file+              [ "True"+              , "[]"+              -- other modules+              , "test-package"+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"+              , "module Foo where"+              , "module Bar where"+              -- other extensions+              , "True"+              , "[\"test/Foo.hs\", \"test/Bar.hs\"]"+              , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+              , "\"{-# LANGUAGE RecordWildCards #-}\""+              -- dependencies+              , "True"+              , "[\"test/Main.hs\"]"+              , "True"+              , "test-package"+              , "module Main where"+              , "import Test.Tasty\nimport Test.Tasty.HUnit"+              , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"+              -- build tools+              , "True"+              , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"+              ]+            flags = emptyFlags {initializeTestSuite = Flag True}++        case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of+          Left e -> assertFailure $ show e+          Right{} -> return ()+    ]+  ]++nonInteractiveTests+  :: InstalledPackageIndex+  -> SourcePackageDb+  -> Compiler+  -> TestTree+nonInteractiveTests pkgIx srcDb comp = testGroup "Check top level getter functions"+    [ testGroup "Simple heuristics tests"+      [ testGroup "Check packageNameHeuristics output"+        [ testSimple "New package name" (packageNameHeuristics srcDb)+          (mkPackageName "test-package")+          [ "test-package"+          , "test-package"+          ]+        , testSimple "Existing package name" (packageNameHeuristics srcDb)+          (mkPackageName "cabal-install")+          [ "test-package"+          , "cabal-install"+          ]+        ]+      , testSimple "Check authorHeuristics output" authorHeuristics "Foobar"+          [ ""+          , "Foobar"+          ]+      , testSimple "Check emailHeuristics output" emailHeuristics "foobar@qux.com"+          [ ""+          , "foobar@qux.com"+          ]+      , testSimple "Check srcDirsHeuristics output" srcDirsHeuristics ["src"]+          [ "src"+          , "True"+          ]+      , testSimple "Check appDirsHeuristics output" appDirsHeuristics ["app"]+          [ "test-package"+          , "[\"test-package/app/\"]"+          ]+      , testGroup "Check packageTypeHeuristics output"+          [ testSimple "Library" packageTypeHeuristics Library+            [ "test-package"+            , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"+            , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"+            ]+          , testSimple "Executable" packageTypeHeuristics Executable+            [ "test-package"+            , "[\".\", \"..\", \"app/Main.hs\"]"+            , "[\".\", \"..\", \"app/Main.hs\"]"+            ]+          , testSimple "Library and Executable" packageTypeHeuristics LibraryAndExecutable+            [ "test-package"+            , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"+            , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"+            ]+          , testSimple "TestSuite" packageTypeHeuristics TestSuite+            [ "test-package"+            , "[\".\", \"..\", \"test/Main.hs\"]"+            , "[\".\", \"..\", \"test/Main.hs\"]"+            ]+          ]+      , testGroup "Check cabalVersionHeuristics output"+          [ testSimple "Broken command" cabalVersionHeuristics defaultCabalVersion+            [""]+          , testSimple "Proper answer" cabalVersionHeuristics CabalSpecV2_4+            ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"]+          ]+      , testGroup "Check languageHeuristics output"+          [ testSimple "Non GHC compiler"+              (`languageHeuristics` (comp {compilerId = CompilerId Helium $ mkVersion [1,8,1]}))+            Haskell2010 []+          , testSimple "Higher version compiler"+              (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [8,10,4]}))+            Haskell2010 []+          , testSimple "Lower version compiler"+              (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [6,0,1]}))+            Haskell98 []+          ]+      , testGroup "Check extraDocFileHeuristics output"+          [ testSimple "No extra sources" extraDocFileHeuristics+            (pure (Set.singleton "CHANGELOG.md"))+            [ "test-package"+            , "[]"+            ]+          , testSimple "Extra doc files present" extraDocFileHeuristics+            (pure $ Set.singleton "README.md")+            [ "test-package"+            , "[\"README.md\"]"+            ]+          ]+      , testGroup "Check mainFileHeuristics output"+          [ testSimple "No main file defined" mainFileHeuristics+            (toHsFilePath "Main.hs")+            [ "test-package"+            , "[\"test-package/app/\"]"+            , "True"+            , "[]"+            ]+          , testSimple "Main file already defined" mainFileHeuristics+            (toHsFilePath "app/Main.hs")+            [ "test-package"+            , "[\"test-package/app/\"]"+            , "True"+            , "[\"app/Main.hs\"]"+            ]+          , testSimple "Main lhs file already defined" mainFileHeuristics+            (toHsFilePath "app/Main.lhs")+            [ "test-package"+            , "[\"test-package/app/\"]"+            , "True"+            , "[\"app/Main.lhs\"]"+            ]+          ]+      , testGroup "Check exposedModulesHeuristics output"+          [ testSimple "Default exposed modules" exposedModulesHeuristics+            (myLibModule NEL.:| [])+            [ "src"+            , "True"+            , "True"+            , "[]"+            , "test-package"+            , "True"+            , "[]"+            ]+          , testSimple "Contains exposed modules" exposedModulesHeuristics+            (NEL.fromList $ map fromString ["Foo", "Bar"])+            [ "src"+            , "True"+            , "True"+            , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+            , "module Foo where"+            , "module Bar where"+            , "test-package"+            , "True"+            , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+            , "module Foo where"+            , "module Bar where"+            ]+          ]+      , testGroup "Check libOtherModulesHeuristics output"+          [ testSimple "Library directory exists" libOtherModulesHeuristics+            (map fromString ["Baz.Internal"])+            [ "test-package"+            , "True"+            , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"+            , "module Foo where"+            , "module Bar where"+            , "module Baz.Internal where"+            ]+          , testSimple "Library directory doesn't exist" libOtherModulesHeuristics []+            [ "test-package"+            , "False"+            ]+          ]+      , testGroup "Check exeOtherModulesHeuristics output"+          [ testSimple "Executable directory exists" exeOtherModulesHeuristics+            (map fromString ["Foo", "Bar"])+            [ "test-package"+            , "True"+            , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"+            , "module Foo where"+            , "module Bar where"+            ]+          , testSimple "Executable directory doesn't exist" exeOtherModulesHeuristics []+            [ "test-package"+            , "False"+            ]+          ]+      , testGroup "Check testOtherModulesHeuristics output"+          [ testSimple "Test directory exists" testOtherModulesHeuristics+            (map fromString ["Foo", "Bar"])+            [ "test-package"+            , "True"+            , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"+            , "module Foo where"+            , "module Bar where"+            ]+          , testSimple "Test directory doesn't exist" testOtherModulesHeuristics []+            [ "test-package"+            , "False"+            ]+          ]+      , testGroup "Check dependenciesHeuristics output"+          [ testSimple "base version bounds is correct"+            (fmap+              (flip foldl' anyVersion $ \a (Dependency n v _) ->+                if unPackageName n == "base" && baseVersion comp /= anyVersion+                  then v else a)+            . (\x -> dependenciesHeuristics x "" pkgIx))+            (baseVersion comp)+            [ "True"+            , "[]"+            ]+          ]+      , testSimple "Check buildToolsHeuristics output" (\a -> buildToolsHeuristics a "" defaultCabalVersion)+          [mkStringyDep "happy:happy"]+          [ "True"+          , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"+          ]+      , testSimple "Check otherExtsHeuristics output" (`otherExtsHeuristics` "")+          (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards])+          [ "True"+          , "[\"src/Foo.hs\", \"src/Bar.hs\"]"+          , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""+          , "\"{-# LANGUAGE RecordWildCards #-}\""+          ]++      , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0,1,0,0]) [""]+      , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""]+      , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""]+      , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""]+      , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""]+      , testSimple "Check minimalHeuristics output" minimalHeuristics False [""]+      , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""]+      , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""]+      , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""]+      ]+    , testGroup "Bool heuristics tests"+      [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False ""+      ]+    ]++testSimple+  :: Eq a+  => Show a+  => String+  -> (InitFlags -> PurePrompt a)+  -> a+  -> [String]+  -> TestTree+testSimple label f target =+  testGo label f (assertFailure . show) (\(a, _) -> target @=? a)++testBool+  :: String+  -> (InitFlags -> PurePrompt Bool)+  -> Bool+  -> String+  -> TestTree+testBool label f target input =+  testSimple label f target [input]++testGo+  :: Eq a+  => Show a+  => String+  -> (InitFlags -> PurePrompt a)+  -> (BreakException -> Assertion)+  -> ((a, NEL.NonEmpty String) -> Assertion)+  -> [String]+  -> TestTree+testGo label f g h inputs = testCase label $+  case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of+    Left  x -> g x+    Right x -> h x
+ tests/UnitTests/Distribution/Client/Init/Simple.hs view
@@ -0,0 +1,168 @@+module UnitTests.Distribution.Client.Init.Simple+( tests+) where+++import Prelude as P+import Test.Tasty+import Test.Tasty.HUnit++import Distribution.Client.Init.Defaults+import Distribution.Client.Init.Simple+import Distribution.Client.Init.Types+++import Data.List.NonEmpty hiding (zip)+import Distribution.Client.Types+import Distribution.Simple.PackageIndex hiding (fromList)+import Distribution.Types.PackageName+import Distribution.Verbosity+++import UnitTests.Distribution.Client.Init.Utils+import Distribution.Simple.Setup+import qualified Data.List.NonEmpty as NEL+import Distribution.Types.Dependency+import Distribution.Client.Init.Utils (mkPackageNameDep, getBaseDep)+import qualified Data.Set as Set+import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)++tests+    :: Verbosity+    -> InitFlags+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> TestTree+tests v _initFlags pkgIx srcDb = testGroup "Distribution.Client.Init.Simple.hs"+    [ simpleCreateProjectTests v pkgIx srcDb pkgName+    ]+  where+    pkgName = mkPackageName "simple-test"++simpleCreateProjectTests+    :: Verbosity+    -> InstalledPackageIndex+    -> SourcePackageDb+    -> PackageName+    -> TestTree+simpleCreateProjectTests v pkgIx srcDb pkgName =+    testGroup "Simple createProject tests"+    [ testCase "Simple lib createProject - no tests" $ do+      let inputs = fromList+            [ "1"           -- package type: Library+            , "simple-test" -- package dir (ignored, piped to current dir due to prompt monad)+            , "n"           -- no tests+            ]++          flags = emptyFlags { packageType = Flag Library }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)+            Nothing Nothing++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e+        Right (settings', _) -> settings @=? settings'++    , testCase "Simple lib createProject - with tests" $ do+      let inputs = fromList ["1", "simple-test", "y", "1"]+          flags = emptyFlags { packageType = Flag Library }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)+            Nothing (Just $ simpleTestTarget (Just pkgName) baseDep)++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e+        Right (settings', _) -> settings @=? settings'++    , testCase "Simple exe createProject" $ do+      let inputs = fromList ["2", "simple-test"]+          flags = emptyFlags { packageType = Flag Executable }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) Nothing+            (Just $ simpleExeTarget Nothing baseDep) Nothing++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e+        Right (settings', _) -> settings @=? settings'++    , testCase "Simple lib+exe createProject - no tests" $ do+      let inputs = fromList ["2", "simple-test", "n"]+          flags = emptyFlags { packageType = Flag LibraryAndExecutable }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)+            (Just $ simpleExeTarget (Just pkgName) baseDep) Nothing++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e+        Right (settings', _) -> settings @=? settings'+    , testCase "Simple lib+exe createProject - with tests" $ do+      let inputs = fromList ["2", "simple-test", "y", "1"]+          flags = emptyFlags { packageType = Flag LibraryAndExecutable }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)+            (Just $ simpleExeTarget (Just pkgName) baseDep)+            (Just $ simpleTestTarget (Just pkgName) baseDep)++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e+        Right (settings', _) -> settings @=? settings'++    , testCase "Simple standalone tests" $ do+      let inputs = fromList ["2", "simple-test", "y", "1"]+          flags = emptyFlags { packageType = Flag TestSuite }+          settings = ProjectSettings+            (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion)+            (simplePkgDesc pkgName) Nothing Nothing+            (Just $ simpleTestTarget Nothing baseDep)++      case _runPrompt (createProject v pkgIx srcDb flags) inputs of+        Left e -> assertFailure $ "Failed to create simple standalone test project: " ++ show e+        Right (settings', _) -> settings @=? settings'+    ]+  where+    baseDep = case _runPrompt (getBaseDep pkgIx emptyFlags) $ fromList [] of+      Left e -> error $ show e+      Right a -> fst a++-- -------------------------------------------------------------------- --+-- Utils++mkPkgDep :: Maybe PackageName -> [Dependency]+mkPkgDep Nothing = []+mkPkgDep (Just pn) = [mkPackageNameDep pn]++simplePkgDesc :: PackageName -> PkgDescription+simplePkgDesc pkgName = PkgDescription+    defaultCabalVersion+    pkgName+    defaultVersion+    (defaultLicense $ getCabalVersionNoPrompt dummyFlags)+    "" "" "" "" ""+    mempty+    (Just $ Set.singleton defaultChangelog)++simpleLibTarget :: [Dependency] -> LibTarget+simpleLibTarget baseDep = LibTarget+    [defaultSourceDir]+    defaultLanguage+    (myLibModule NEL.:| [])+    [] [] baseDep []++simpleExeTarget :: Maybe PackageName -> [Dependency] -> ExeTarget+simpleExeTarget pn baseDep = ExeTarget+    defaultMainIs+    [defaultApplicationDir]+    defaultLanguage+    [] [] (baseDep ++ mkPkgDep pn) []++simpleTestTarget :: Maybe PackageName -> [Dependency] -> TestTarget+simpleTestTarget pn baseDep = TestTarget+    defaultMainIs+    [defaultTestDir]+    defaultLanguage+    [] [] (baseDep ++ mkPkgDep pn) []
+ tests/UnitTests/Distribution/Client/Init/Utils.hs view
@@ -0,0 +1,108 @@+module UnitTests.Distribution.Client.Init.Utils+( dummyFlags+, emptyFlags+, mkLicense+, baseVersion+, mangleBaseDep+, (@?!)+, (@!?)+) where+++import Distribution.Client.Init.Types++import qualified Distribution.SPDX as SPDX++import Distribution.CabalSpecVersion+import Distribution.Simple.Setup+import Distribution.Types.PackageName+import Distribution.Types.Version+import Language.Haskell.Extension+import Test.Tasty.HUnit+import Distribution.Types.Dependency+import Distribution.Types.VersionRange+import Distribution.Simple.Compiler+import Distribution.Pretty+import Distribution.FieldGrammar.Newtypes+++-- -------------------------------------------------------------------- --+-- Test flags++dummyFlags :: InitFlags+dummyFlags = emptyFlags+  { noComments          = Flag True+  , packageName         = Flag (mkPackageName "QuxPackage")+  , version             = Flag (mkVersion [4,2,6])+  , cabalVersion        = Flag CabalSpecV2_2+  , license             = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing+  , author              = Flag "Foobar"+  , email               = Flag "foobar@qux.com"+  , homepage            = Flag "qux.com"+  , synopsis            = Flag "We are Qux, and this is our package"+  , category            = Flag "Control"+  , language            = Flag Haskell98+  , initializeTestSuite = Flag True+  , sourceDirs          = Flag ["quxSrc"]+  , testDirs            = Flag ["quxTest"]+  , applicationDirs     = Flag ["quxApp"]+  }++emptyFlags :: InitFlags+emptyFlags = mempty++-- | Retireves the proper base version based on the GHC version+baseVersion :: Compiler -> VersionRange+baseVersion Compiler {compilerId = CompilerId GHC ver} =+  let ghcToBase = baseVersion' . prettyShow $ ver in+        if null ghcToBase+          then anyVersion+          else majorBoundVersion $ mkVersion ghcToBase+baseVersion _ = anyVersion++baseVersion' :: String -> [Int]+baseVersion' "9.0.1"  = [4,15,0,0]+baseVersion' "8.10.4" = [4,14,1,0]+baseVersion' "8.8.4"  = [4,13,0,0]+baseVersion' "8.6.5"  = [4,12,0,0]+baseVersion' "8.4.4"  = [4,11,1,0]+baseVersion' "8.2.2"  = [4,10,1,0]+baseVersion' "8.0.2"  = [4,10,0,0]+baseVersion' "7.10.3" = [4,9,0,0]+baseVersion' "7.8.4"  = [4,8,0,0]+baseVersion' "7.6.3"  = [4,7,0,0]+baseVersion' _ = []++-- -------------------------------------------------------------------- --+-- Test utils++mkLicense :: SPDX.LicenseId -> SPDX.License+mkLicense lid = SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)++mangleBaseDep :: a -> (a -> [Dependency]) -> [Dependency]+mangleBaseDep target f =+    [ if unPackageName x == "base"+        then Dependency x anyVersion z+        else dep+    | dep@(Dependency x _ z) <- f target+    ]++infix 1 @?!, @!?++-- | Just like @'@?='@, except it checks for difference rather than equality.+(@?!)+  :: (Eq a, Show a, HasCallStack)+  => a+  -> a+  -> Assertion+actual @?! unexpected = assertBool+                          ("unexpected: " ++ show unexpected)+                          (actual /= unexpected)++-- | Just like @'@=?'@, except it checks for difference rather than equality.+(@!?)+  :: (Eq a, Show a, HasCallStack)+  => a+  -> a+  -> Assertion+(@!?) = flip (@?!)
+ tests/UnitTests/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE ConstraintKinds #-}+module UnitTests.Distribution.Client.InstallPlan (tests) where++import Distribution.Client.Compat.Prelude+import qualified Prelude as Unsafe (tail)++import           Distribution.Package+import           Distribution.Version+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)+import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph (IsNode(..))+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.PackageFixedDeps+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Client.Types+import           Distribution.Client.JobControl++import Data.Graph+import Data.Array hiding (index)+import Data.List ()+import Control.Monad (replicateM)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IORef+import Control.Concurrent (threadDelay)+import System.Random+import Test.QuickCheck++import Test.Tasty+import Test.Tasty.QuickCheck+++tests :: [TestTree]+tests =+  [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder+  , testProperty "executionOrder"          prop_executionOrder+  , testProperty "execute serial"          prop_execute_serial+  , testProperty "execute parallel"        prop_execute_parallel+  , testProperty "execute/executionOrder"  prop_execute_vs_executionOrder+  ]++prop_reverseTopologicalOrder :: TestInstallPlan -> Bool+prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =+    isReverseTopologicalOrder+      graph+      (map (toVertex . installedUnitId)+           (InstallPlan.reverseTopologicalOrder plan))++-- | @executionOrder@ is in reverse topological order+prop_executionOrder :: TestInstallPlan -> Bool+prop_executionOrder (TestInstallPlan plan graph toVertex _) =+    isReversePartialTopologicalOrder graph (map toVertex pkgids)+ && allConfiguredPackages plan == Set.fromList pkgids+  where+    pkgids = map installedUnitId (InstallPlan.executionOrder plan)++-- | @execute@ is in reverse topological order+prop_execute_serial :: TestInstallPlan -> Property+prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property+prop_execute_parallel (Positive (Small maxJobLimit))+                      tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newParallelJobControl maxJobLimit+      pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do+                  delay <- randomRIO (0,1000)+                  threadDelay delay+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++-- | return the packages that are visited by execute, in order.+executeTestInstallPlan :: JobControl IO (UnitId, Either () ())+                       -> TestInstallPlan+                       -> (TestPkg -> IO ())+                       -> IO [UnitId]+executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do+    resultsRef <- newIORef []+    _ <- InstallPlan.execute jobCtl False (const ())+                             plan $ \(ReadyPackage pkg) -> do+           visit pkg+           atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ())+           return (Right ())+    fmap reverse (readIORef resultsRef)++-- | @execute@ visits the packages in the same order as @executionOrder@+prop_execute_vs_executionOrder :: TestInstallPlan -> Property+prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)+      return (pkgids == pkgids')+++--------------------------+-- Property helper utils+--++-- | A graph topological ordering is a linear ordering of its vertices such+-- that for every directed edge uv from vertex u to vertex v, u comes before v+-- in the ordering.+--+-- A reverse topological ordering is the swapped: for every directed edge uv+-- from vertex u to vertex v, v comes before u in the ordering.+--+isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool+isReverseTopologicalOrder g vs =+    and [ ixs ! u > ixs ! v+        | let ixs = array (bounds g) (zip vs [0::Int ..])+        , (u,v) <- edges g ]++isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool+isReversePartialTopologicalOrder g vs =+    and [ case (ixs ! u, ixs ! v) of+            (Just ixu, Just ixv) -> ixu > ixv+            _                    -> True+        | let ixs = array (bounds g)+                          (zip (range (bounds g)) (repeat Nothing) ++ +                           zip vs (map Just [0::Int ..]))+        , (u,v) <- edges g ]++allConfiguredPackages :: HasUnitId srcpkg+                      => GenericInstallPlan ipkg srcpkg -> Set UnitId+allConfiguredPackages plan =+    Set.fromList+      [ installedUnitId pkg+      | InstallPlan.Configured pkg <- InstallPlan.toList plan ]+++--------------------+-- Test generators+--++data TestInstallPlan = TestInstallPlan+                         (GenericInstallPlan TestPkg TestPkg)+                         Graph+                         (UnitId -> Vertex)+                         (Vertex -> UnitId)++instance Show TestInstallPlan where+  show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan++data TestPkg = TestPkg PackageId UnitId [UnitId]+  deriving (Eq, Show)++instance IsNode TestPkg where+  type Key TestPkg = UnitId+  nodeKey (TestPkg _ ipkgid _) = ipkgid+  nodeNeighbors (TestPkg _ _ deps) = deps+++instance Package TestPkg where+  packageId (TestPkg pkgid _ _) = pkgid++instance HasUnitId TestPkg where+  installedUnitId (TestPkg _ ipkgid _) = ipkgid++instance PackageFixedDeps TestPkg where+  depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps++instance PackageInstalled TestPkg where+  installedDepends (TestPkg _ _ deps) = deps++instance Arbitrary TestInstallPlan where+  arbitrary = arbitraryTestInstallPlan++arbitraryTestInstallPlan :: Gen TestInstallPlan+arbitraryTestInstallPlan = do+    graph <- arbitraryAcyclicGraph+               (choose (2,5))+               (choose (1,5))+               0.3++    plan  <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph++    let toVertexMap   = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ]+        fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ]+        toVertex      = (toVertexMap   Map.!)+        fromVertex    = (fromVertexMap Map.!)++    return (TestInstallPlan plan graph toVertex fromVertex)+  where+    mkTestPkg pkgv depvs =+        return (TestPkg pkgid ipkgid deps)+      where+        pkgid  = mkPkgId pkgv+        ipkgid = mkUnitIdV pkgv+        deps   = map mkUnitIdV depvs+    mkUnitIdV = mkUnitId . show+    mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v))+                                  (mkVersion [1])+++-- | Generate a random 'InstallPlan' following the structure of an existing+-- 'Graph'.+--+-- It takes generators for installed and source packages and the chance that+-- each package is installed (for those packages with no prerequisites).+--+arbitraryInstallPlan :: (IsUnit ipkg,+                         IsUnit srcpkg)+                     => (Vertex -> [Vertex] -> Gen ipkg)+                     -> (Vertex -> [Vertex] -> Gen srcpkg)+                     -> Float+                     -> Graph+                     -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)+arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do++    (ipkgvs, srcpkgvs) <-+      fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))+            . partition snd) $+      sequenceA+        [ do isipkg <- if isRoot then pick ipkgProportion+                                 else return False+             return (v, isipkg)+        | (v,n) <- assocs (outdegree graph)+        , let isRoot = n == 0 ]++    ipkgs   <- sequenceA+                 [ mkIPkg pkgv depvs+                 | pkgv <- ipkgvs+                 , let depvs  = graph ! pkgv+                 ]+    srcpkgs <- sequenceA+                 [ mkSrcPkg pkgv depvs+                 | pkgv <- srcpkgvs+                 , let depvs  = graph ! pkgv+                 ]+    let index = Graph.fromDistinctList+                   (map InstallPlan.PreExisting ipkgs+                 ++ map InstallPlan.Configured  srcpkgs)+    return $ InstallPlan.new (IndependentGoals False) index+++-- | Generate a random directed acyclic graph, based on the algorithm presented+-- here <http://stackoverflow.com/questions/12790337/generating-a-random-dag>+--+-- It generates a DAG based on ranks of nodes. Nodes in each rank can only+-- have edges to nodes in subsequent ranks.+--+-- The generator is parametrised by a generator for the number of ranks and+-- the number of nodes within each rank. It is also parametrised by the+-- chance that each node in each rank will have an edge from each node in+-- each previous rank. Thus a higher chance will produce a more densely+-- connected graph.+--+arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph+arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do+    nranks    <- genNRanks+    rankSizes <- replicateM nranks genNPerRank+    let rankStarts = scanl (+) 0 rankSizes+        rankRanges = drop 1 (zip rankStarts (Unsafe.tail rankStarts))+        totalRange = sum rankSizes+    rankEdges <- traverse (uncurry genRank) rankRanges+    return $ buildG (0, totalRange-1) (concat rankEdges)+  where+    genRank :: Vertex -> Vertex -> Gen [Edge]+    genRank rankStart rankEnd =+      filterM (const (pick edgeChance))+        [ (i,j)+        | i <- [0..rankStart-1]+        , j <- [rankStart..rankEnd-1]+        ]++pick :: Float -> Gen Bool+pick chance = do+    p <- choose (0,1)+    return (p < chance)+++--------------------------------+-- Inspecting generated graphs+--++{-+-- Handy util for checking the generated graphs look sensible+writeDotFile :: FilePath -> Graph -> IO ()+writeDotFile file = writeFile file . renderDotGraph++renderDotGraph :: Graph -> String+renderDotGraph graph =+  unlines (+      [header+      ,graphDefaultAtribs+      ,nodeDefaultAtribs+      ,edgeDefaultAtribs]+    ++ map renderNode (vertices graph)+    ++ map renderEdge (edges graph)+    ++ [footer]+  )+  where+    renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++  "\"];"++    renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];"+++header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String++header = "digraph packages {"+footer = "}"++graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];"+nodeDefaultAtribs  = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];"+edgeDefaultAtribs  = "\tedge [fontsize=10];"+-}
+ tests/UnitTests/Distribution/Client/JobControl.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveDataTypeable #-}+module UnitTests.Distribution.Client.JobControl (tests) where++import Distribution.Client.JobControl++import Distribution.Client.Compat.Prelude+import Prelude ()++import Data.IORef (newIORef, atomicModifyIORef)+import Control.Monad (replicateM_, replicateM)+import Control.Concurrent (threadDelay)+import Control.Exception  (try)+import qualified Data.Set as Set++import Test.Tasty+import Test.Tasty.QuickCheck hiding (collect)+++tests :: [TestTree]+tests =+  [ testGroup "serial"+      [ testProperty "submit batch"       prop_submit_serial+      , testProperty "submit batch"       prop_remaining_serial+      , testProperty "submit interleaved" prop_interleaved_serial+      , testProperty "concurrent jobs"    prop_concurrent_serial+      , testProperty "cancel"             prop_cancel_serial+      , testProperty "exceptions"         prop_exception_serial+      ]+  , testGroup "parallel"+      [ testProperty "submit batch"       prop_submit_parallel+      , testProperty "submit batch"       prop_remaining_parallel+      , testProperty "submit interleaved" prop_interleaved_parallel+      , testProperty "concurrent jobs"    prop_concurrent_parallel+      , testProperty "cancel"             prop_cancel_parallel+      , testProperty "exceptions"         prop_exception_parallel+      ]+  ]+++prop_submit_serial :: [Int] -> Property+prop_submit_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit jobCtl xs++prop_submit_parallel :: Positive (Small Int) -> [Int] -> Property+prop_submit_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit jobCtl xs++prop_remaining_serial :: [Int] -> Property+prop_remaining_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_remaining jobCtl xs++prop_remaining_parallel :: Positive (Small Int) -> [Int] -> Property+prop_remaining_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_remaining jobCtl xs++prop_interleaved_serial :: [Int] -> Property+prop_interleaved_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit_interleaved jobCtl xs++prop_interleaved_parallel :: Positive (Small Int) -> [Int] -> Property+prop_interleaved_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit_interleaved jobCtl xs++prop_submit :: JobControl IO Int -> [Int] -> IO Bool+prop_submit jobCtl xs = do+    traverse_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- traverse (\_ -> collectJob jobCtl) xs+    return (sort xs == sort xs')++prop_remaining :: JobControl IO Int -> [Int] -> IO Bool+prop_remaining jobCtl xs = do+    traverse_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs')++collectRemainingJobs :: Monad m => JobControl m a -> m [a]+collectRemainingJobs jobCtl = go []+  where+    go xs = do+      remaining <- remainingJobs jobCtl+      if remaining+        then do x <- collectJob jobCtl+                go (x:xs)+        else return xs++prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool+prop_submit_interleaved jobCtl xs = do+    xs' <- sequenceA+      [ spawn >> collect+      | let spawns   = map (\x -> spawnJob jobCtl (return (Just x))) xs+                    ++ repeat (return ())+            collects = replicate 5 (return Nothing)+                    ++ map (\_ -> collectJob jobCtl) xs+      , (spawn, collect) <- zip spawns collects+      ]+    return (sort xs == sort (catMaybes xs'))++prop_concurrent_serial :: NonNegative (Small Int) -> Property+prop_concurrent_serial (NonNegative (Small ntasks)) =+  ioProperty $ do+    jobCtl   <- newSerialJobControl+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property+prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) =+  ioProperty $ do+    jobCtl   <- newParallelJobControl maxJobLimit+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 >= 0 && n0 <  maxJobLimit+                            && n1 >  0 && n1 <= maxJobLimit) counts+             -- we do hit the concurrency limit (in the right circumstances)+          && if ntasks >= maxJobLimit*2 -- give us enough of a margin+               then any (\(_,n1) -> n1 == maxJobLimit) counts+               else True+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_cancel_serial :: [Int] -> [Int] -> Property+prop_cancel_serial xs ys =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    traverse_ (\x -> spawnJob jobCtl (return x)) (xs++ys)+    xs' <- traverse (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs' && null ys')++prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property+prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    traverse_ (\x -> spawnJob jobCtl (threadDelay 100  >> return x)) (xs++ys)+    xs' <- traverse (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys)++data TestException = TestException Int+  deriving (Typeable, Show)++instance Exception TestException++prop_exception_serial :: [Either Int Int] -> Property+prop_exception_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_exception jobCtl xs++prop_exception_parallel :: Positive (Small Int) -> [Either Int Int] -> Property+prop_exception_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_exception jobCtl xs++prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool+prop_exception jobCtl xs = do+    traverse_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs+    xs' <- replicateM (length xs) $ do+             mx <- try (collectJob jobCtl)+             return $ case mx of+               Left (TestException n) -> Left  n+               Right               n  -> Right n+    return (sort xs == sort xs')+
+ tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,807 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- simplifier goes nuts otherwise+#if __GLASGOW_HASKELL__ < 806+{-# OPTIONS_GHC -funfolding-use-threshold=30 #-}+#endif++module UnitTests.Distribution.Client.ProjectConfig (tests) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Control.Applicative+#endif+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List (isPrefixOf, intercalate, (\\))+import Network.URI (URI)++import Distribution.Deprecated.ParseUtils+import qualified Distribution.Deprecated.ReadP as Parse++import Distribution.Package+import Distribution.PackageDescription+import Distribution.Compiler+import Distribution.Version+import Distribution.Simple.Program.Types+import Distribution.Simple.Program.Db+import Distribution.Simple.Utils (toUTF8BS)+import Distribution.Types.PackageVersionConstraint++import Distribution.Parsec+import Distribution.Pretty++import Distribution.Client.Types+import Distribution.Client.CmdInstall.ClientInstallFlags+import Distribution.Client.Dependency.Types+import Distribution.Client.Targets+import Distribution.Client.Types.SourceRepo+import Distribution.Utils.NubList++import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.Settings++import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectConfig.Legacy++import UnitTests.Distribution.Client.ArbitraryInstances+import UnitTests.Distribution.Client.TreeDiffInstances ()++import Data.TreeDiff.Class+import Data.TreeDiff.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+  [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $+    [ testProperty "packages"  prop_roundtrip_legacytypes_packages+    , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly+    , testProperty "specific"  prop_roundtrip_legacytypes_specific+    ] +++    -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older+    -- unclear why as of yet+    concat+    [ [ testProperty "shared"    prop_roundtrip_legacytypes_shared+      , testProperty "local"     prop_roundtrip_legacytypes_local+      , testProperty "all"       prop_roundtrip_legacytypes_all+      ]+    | not usingGhc76orOlder+    ]++  , testGroup "individual parser tests"+    [ testProperty "package location"  prop_parsePackageLocationTokenQ+    , testProperty "RelaxedDep"        prop_roundtrip_printparse_RelaxedDep+    , testProperty "RelaxDeps"         prop_roundtrip_printparse_RelaxDeps+    , testProperty "RelaxDeps'"        prop_roundtrip_printparse_RelaxDeps'+    ]++  , testGroup "ProjectConfig printing/parsing round trip"+    [ testProperty "packages"  prop_roundtrip_printparse_packages+    , testProperty "buildonly" prop_roundtrip_printparse_buildonly+    , testProperty "shared"    prop_roundtrip_printparse_shared+    , testProperty "local"     prop_roundtrip_printparse_local+    , testProperty "specific"  prop_roundtrip_printparse_specific+    , testProperty "all"       prop_roundtrip_printparse_all+    ]+  ]+  where+    usingGhc76orOlder =+      case buildCompilerId of+        CompilerId GHC v -> v < mkVersion [7,7]+        _                -> False+++------------------------------------------------+-- Round trip: conversion to/from legacy types+--++roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property+roundtrip f f_inv x =+    counterexample (show y) $+    x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr+  where+    y = f x++roundtrip_legacytypes :: ProjectConfig -> Property+roundtrip_legacytypes =+    roundtrip convertToLegacyProjectConfig+              convertLegacyProjectConfig+++prop_roundtrip_legacytypes_all :: ProjectConfig -> Property+prop_roundtrip_legacytypes_all config =+    roundtrip_legacytypes+      config {+        projectConfigProvenance = mempty+      }++prop_roundtrip_legacytypes_packages :: ProjectConfig -> Property+prop_roundtrip_legacytypes_packages config =+    roundtrip_legacytypes+      config {+        projectConfigBuildOnly       = mempty,+        projectConfigShared          = mempty,+        projectConfigProvenance      = mempty,+        projectConfigLocalPackages   = mempty,+        projectConfigSpecificPackage = mempty+      }++prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Property+prop_roundtrip_legacytypes_buildonly config =+    roundtrip_legacytypes+      mempty { projectConfigBuildOnly = config }++prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Property+prop_roundtrip_legacytypes_shared config =+    roundtrip_legacytypes+      mempty { projectConfigShared = config }++prop_roundtrip_legacytypes_local :: PackageConfig -> Property+prop_roundtrip_legacytypes_local config =+    roundtrip_legacytypes+      mempty { projectConfigLocalPackages = config }++prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Property+prop_roundtrip_legacytypes_specific config =+    roundtrip_legacytypes+      mempty { projectConfigSpecificPackage = MapMappend config }+++--------------------------------------------+-- Round trip: printing and parsing config+--++roundtrip_printparse :: ProjectConfig -> Property+roundtrip_printparse config =+    case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of+      ParseOk _ x     -> counterexample ("shown:\n" ++ str) $+          x `ediffEq` config { projectConfigProvenance = mempty }+      ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False+  where+    str :: String+    str = showLegacyProjectConfig (convertToLegacyProjectConfig config)+++prop_roundtrip_printparse_all :: ProjectConfig -> Property+prop_roundtrip_printparse_all config =+    roundtrip_printparse config {+      projectConfigBuildOnly =+        hackProjectConfigBuildOnly (projectConfigBuildOnly config),++      projectConfigShared =+        hackProjectConfigShared (projectConfigShared config)+    }++prop_roundtrip_printparse_packages :: [PackageLocationString]+                                   -> [PackageLocationString]+                                   -> [SourceRepoList]+                                   -> [PackageVersionConstraint]+                                   -> Property+prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =+    roundtrip_printparse+      mempty {+        projectPackages         = map getPackageLocationString pkglocstrs1,+        projectPackagesOptional = map getPackageLocationString pkglocstrs2,+        projectPackagesRepo     = repos,+        projectPackagesNamed    = named+      }++prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property+prop_roundtrip_printparse_buildonly config =+    roundtrip_printparse+      mempty {+        projectConfigBuildOnly = hackProjectConfigBuildOnly config+      }++hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly+hackProjectConfigBuildOnly config =+    config {+      -- These fields are only command line transitory things, not+      -- something to be recorded persistently in a config file+      projectConfigOnlyDeps     = mempty,+      projectConfigOnlyDownload = mempty,+      projectConfigDryRun       = mempty+    }++prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property+prop_roundtrip_printparse_shared config =+    roundtrip_printparse+      mempty {+        projectConfigShared = hackProjectConfigShared config+      }++hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared+hackProjectConfigShared config =+    config {+      projectConfigProjectFile = mempty, -- not present within project files+      projectConfigConfigFile  = mempty, -- ditto+      projectConfigConstraints =+      --TODO: [required eventually] parse ambiguity in constraint+      -- "pkgname -any" as either any version or disabled flag "any".+        let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) =+              (not . null) [ () | (name, False) <- unFlagAssignment flags+                                , "any" `isPrefixOf` unFlagName name ]+            ambiguous _ = False+         in filter (not . ambiguous) (projectConfigConstraints config)+    }+++prop_roundtrip_printparse_local :: PackageConfig -> Property+prop_roundtrip_printparse_local config =+    roundtrip_printparse+      mempty {+        projectConfigLocalPackages = config+      }++prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)+                                   -> Property+prop_roundtrip_printparse_specific config =+    roundtrip_printparse+      mempty {+        projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)+      }+++----------------------------+-- Individual Parser tests+--++-- | Helper to parse a given string+--+-- Succeeds only if there is a unique complete parse+runReadP :: Parse.ReadP a a -> String -> Maybe a+runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of+                      [x'] -> Just x'+                      _    -> Nothing++prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool+prop_parsePackageLocationTokenQ (PackageLocationString str) =+    runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str++prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property+prop_roundtrip_printparse_RelaxedDep rdep =+    counterexample (prettyShow rdep) $+    eitherParsec (prettyShow rdep) == Right rdep++prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property+prop_roundtrip_printparse_RelaxDeps rdep =+    counterexample (prettyShow rdep) $+    Right rdep `ediffEq` eitherParsec (prettyShow rdep)++prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property+prop_roundtrip_printparse_RelaxDeps' rdep =+    counterexample rdep' $+    Right rdep `ediffEq` eitherParsec rdep'+  where+    rdep' = go (prettyShow rdep)++    -- replace 'all' tokens by '*'+    go :: String -> String+    go [] = []+    go "all" = "*"+    go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest)+    go rest = let (x,y) = break (`elem` ":,") rest+                  (x',y') = span (`elem` ":,^") y+              in x++x'++go y'++------------------------+-- Arbitrary instances+--++instance Arbitrary ProjectConfig where+    arbitrary =+      ProjectConfig+        <$> (map getPackageLocationString <$> arbitrary)+        <*> (map getPackageLocationString <$> arbitrary)+        <*> shortListOf 3 arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (MapMappend . fmap getNonMEmpty . Map.fromList+               <$> shortListOf 3 arbitrary)+        -- package entries with no content are equivalent to+        -- the entry not existing at all, so exclude empty++    shrink ProjectConfig { projectPackages = x0+                         , projectPackagesOptional = x1+                         , projectPackagesRepo = x2+                         , projectPackagesNamed = x3+                         , projectConfigBuildOnly = x4+                         , projectConfigShared = x5+                         , projectConfigProvenance = x6+                         , projectConfigLocalPackages = x7+                         , projectConfigSpecificPackage = x8+                         , projectConfigAllPackages = x9 } =+      [ ProjectConfig { projectPackages = x0'+                      , projectPackagesOptional = x1'+                      , projectPackagesRepo = x2'+                      , projectPackagesNamed = x3'+                      , projectConfigBuildOnly = x4'+                      , projectConfigShared = x5'+                      , projectConfigProvenance = x6'+                      , projectConfigLocalPackages = x7'+                      , projectConfigSpecificPackage = (MapMappend+                                                         (fmap getNonMEmpty x8'))+                      , projectConfigAllPackages = x9' }+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9'))+          <- shrink ((x0, x1, x2, x3),+                      (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9))+      ]++newtype PackageLocationString+      = PackageLocationString { getPackageLocationString :: String }+  deriving Show++instance Arbitrary PackageLocationString where+  arbitrary =+    PackageLocationString <$>+    oneof+      [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))+      , arbitraryGlobLikeStr+      , show <$> (arbitrary :: Gen URI)+      ]+      `suchThat` (\xs -> not ("{" `isPrefixOf` xs))++arbitraryGlobLikeStr :: Gen String+arbitraryGlobLikeStr = outerTerm+  where+    outerTerm  = concat <$> shortListOf1 4+                  (frequency [ (2, token)+                             , (1, braces <$> innerTerm) ])+    innerTerm  = intercalate "," <$> shortListOf1 3+                  (frequency [ (3, token)+                             , (1, braces <$> innerTerm) ])+    token      = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))+    braces s   = "{" ++ s ++ "}"+++instance Arbitrary ClientInstallFlags where+    arbitrary =+      ClientInstallFlags+        <$> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken++instance Arbitrary ProjectConfigBuildOnly where+    arbitrary =+      ProjectConfigBuildOnly+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (toNubList <$> shortListOf 2 arbitrary)+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)+        <*> arbitraryNumJobs+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)+        <*> arbitrary+      where+        arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary++    shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00+                                  , projectConfigDryRun = x01+                                  , projectConfigOnlyDeps = x02+                                  , projectConfigOnlyDownload = x18+                                  , projectConfigSummaryFile = x03+                                  , projectConfigLogFile = x04+                                  , projectConfigBuildReports = x05+                                  , projectConfigReportPlanningFailure = x06+                                  , projectConfigSymlinkBinDir = x07+                                  , projectConfigNumJobs = x09+                                  , projectConfigKeepGoing = x10+                                  , projectConfigOfflineMode = x11+                                  , projectConfigKeepTempFiles = x12+                                  , projectConfigHttpTransport = x13+                                  , projectConfigIgnoreExpiry = x14+                                  , projectConfigCacheDir = x15+                                  , projectConfigLogsDir = x16+                                  , projectConfigClientInstallFlags = x17 } =+      [ ProjectConfigBuildOnly { projectConfigVerbosity = x00'+                               , projectConfigDryRun = x01'+                               , projectConfigOnlyDeps = x02'+                               , projectConfigOnlyDownload = x18'+                               , projectConfigSummaryFile = x03'+                               , projectConfigLogFile = x04'+                               , projectConfigBuildReports = x05'+                               , projectConfigReportPlanningFailure = x06'+                               , projectConfigSymlinkBinDir = x07'+                               , projectConfigNumJobs = postShrink_NumJobs x09'+                               , projectConfigKeepGoing = x10'+                               , projectConfigOfflineMode = x11'+                               , projectConfigKeepTempFiles = x12'+                               , projectConfigHttpTransport = x13+                               , projectConfigIgnoreExpiry = x14'+                               , projectConfigCacheDir = x15+                               , projectConfigLogsDir = x16+                               , projectConfigClientInstallFlags = x17' }+      | ((x00', x01', x02', x03', x04'),+         (x05', x06', x07',       x09'),+         (x10', x11', x12',       x14'),+         (            x17', x18'      ))+          <- shrink+               ((x00, x01, x02, x03, x04),+                (x05, x06, x07,      preShrink_NumJobs x09),+                (x10, x11, x12,      x14),+                (          x17, x18     ))+      ]+      where+        preShrink_NumJobs  = fmap (fmap Positive)+        postShrink_NumJobs = fmap (fmap getPositive)++instance Arbitrary ProjectConfigShared where+    arbitrary = do+        projectConfigDistDir              <- arbitraryFlag arbitraryShortToken+        projectConfigConfigFile           <- arbitraryFlag arbitraryShortToken+        projectConfigProjectFile          <- arbitraryFlag arbitraryShortToken+        projectConfigIgnoreProject        <- arbitrary+        projectConfigHcFlavor             <- arbitrary+        projectConfigHcPath               <- arbitraryFlag arbitraryShortToken+        projectConfigHcPkg                <- arbitraryFlag arbitraryShortToken+        projectConfigHaddockIndex         <- arbitrary+        projectConfigPackageDBs           <- shortListOf 2 arbitrary+        projectConfigRemoteRepos          <- arbitrary+        projectConfigLocalNoIndexRepos    <- arbitrary+        projectConfigActiveRepos          <- arbitrary+        projectConfigIndexState           <- arbitrary+        projectConfigStoreDir             <- arbitraryFlag arbitraryShortToken+        projectConfigConstraints          <- arbitraryConstraints+        projectConfigPreferences          <- shortListOf 2 arbitrary+        projectConfigCabalVersion         <- arbitrary+        projectConfigSolver               <- arbitrary+        projectConfigAllowOlder           <- arbitrary+        projectConfigAllowNewer           <- arbitrary+        projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary+        projectConfigMaxBackjumps         <- arbitrary+        projectConfigReorderGoals         <- arbitrary+        projectConfigCountConflicts       <- arbitrary+        projectConfigFineGrainedConflicts <- arbitrary+        projectConfigMinimizeConflictSet  <- arbitrary+        projectConfigStrongFlags          <- arbitrary+        projectConfigAllowBootLibInstalls <- arbitrary+        projectConfigOnlyConstrained      <- arbitrary+        projectConfigPerComponent         <- arbitrary+        projectConfigIndependentGoals     <- arbitrary+        projectConfigProgPathExtra        <- toNubList <$> listOf arbitraryShortToken+        return ProjectConfigShared {..}+      where+        arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]+        arbitraryConstraints =+            fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary++    shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared+        <*> shrinker projectConfigDistDir+        <*> shrinker projectConfigConfigFile+        <*> shrinker projectConfigProjectFile+        <*> shrinker projectConfigIgnoreProject+        <*> shrinker projectConfigHcFlavor+        <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath+        <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg+        <*> shrinker projectConfigHaddockIndex+        <*> shrinker projectConfigPackageDBs+        <*> shrinker projectConfigRemoteRepos+        <*> shrinker projectConfigLocalNoIndexRepos+        <*> shrinker projectConfigActiveRepos+        <*> shrinker projectConfigIndexState+        <*> shrinker projectConfigStoreDir+        <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints+        <*> shrinker projectConfigPreferences+        <*> shrinker projectConfigCabalVersion+        <*> shrinker projectConfigSolver+        <*> shrinker projectConfigAllowOlder+        <*> shrinker projectConfigAllowNewer+        <*> shrinker projectConfigWriteGhcEnvironmentFilesPolicy+        <*> shrinker projectConfigMaxBackjumps+        <*> shrinker projectConfigReorderGoals+        <*> shrinker projectConfigCountConflicts+        <*> shrinker projectConfigFineGrainedConflicts+        <*> shrinker projectConfigMinimizeConflictSet+        <*> shrinker projectConfigStrongFlags+        <*> shrinker projectConfigAllowBootLibInstalls+        <*> shrinker projectConfigOnlyConstrained+        <*> shrinker projectConfigPerComponent+        <*> shrinker projectConfigIndependentGoals+        <*> shrinker projectConfigProgPathExtra+      where+        preShrink_Constraints  = map fst+        postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))++projectConfigConstraintSource :: ConstraintSource+projectConfigConstraintSource =+    ConstraintSourceProjectConfig "unused"++instance Arbitrary ProjectConfigProvenance where+    arbitrary = elements [Implicit, Explicit "cabal.project"]++instance Arbitrary PackageConfig where+    arbitrary =+      PackageConfig+        <$> (MapLast . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> arbitraryShortToken))+        <*> (MapMappend . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> listOf arbitraryShortToken))+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary+        <*> arbitrary <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> shortListOf 5 arbitrary+        <*> shortListOf 5 arbitrary+      where+        arbitraryProgramName :: Gen String+        arbitraryProgramName =+          elements [ programName prog+                   | (prog, _) <- knownPrograms (defaultProgramDb) ]++    shrink PackageConfig { packageConfigProgramPaths = x00+                         , packageConfigProgramArgs = x01+                         , packageConfigProgramPathExtra = x02+                         , packageConfigFlagAssignment = x03+                         , packageConfigVanillaLib = x04+                         , packageConfigSharedLib = x05+                         , packageConfigStaticLib = x42+                         , packageConfigDynExe = x06+                         , packageConfigFullyStaticExe = x50+                         , packageConfigProf = x07+                         , packageConfigProfLib = x08+                         , packageConfigProfExe = x09+                         , packageConfigProfDetail = x10+                         , packageConfigProfLibDetail = x11+                         , packageConfigConfigureArgs = x12+                         , packageConfigOptimization = x13+                         , packageConfigProgPrefix = x14+                         , packageConfigProgSuffix = x15+                         , packageConfigExtraLibDirs = x16+                         , packageConfigExtraLibDirsStatic = x53+                         , packageConfigExtraFrameworkDirs = x17+                         , packageConfigExtraIncludeDirs = x18+                         , packageConfigGHCiLib = x19+                         , packageConfigSplitSections = x20+                         , packageConfigSplitObjs = x20_1+                         , packageConfigStripExes = x21+                         , packageConfigStripLibs = x22+                         , packageConfigTests = x23+                         , packageConfigBenchmarks = x24+                         , packageConfigCoverage = x25+                         , packageConfigRelocatable = x26+                         , packageConfigDebugInfo = x27+                         , packageConfigDumpBuildInfo = x27_1+                         , packageConfigRunTests = x28+                         , packageConfigDocumentation = x29+                         , packageConfigHaddockHoogle = x30+                         , packageConfigHaddockHtml = x31+                         , packageConfigHaddockHtmlLocation = x32+                         , packageConfigHaddockForeignLibs = x33+                         , packageConfigHaddockExecutables = x33_1+                         , packageConfigHaddockTestSuites = x34+                         , packageConfigHaddockBenchmarks = x35+                         , packageConfigHaddockInternal = x36+                         , packageConfigHaddockCss = x37+                         , packageConfigHaddockLinkedSource = x38+                         , packageConfigHaddockQuickJump = x43+                         , packageConfigHaddockHscolourCss = x39+                         , packageConfigHaddockContents = x40+                         , packageConfigHaddockForHackage = x41+                         , packageConfigTestHumanLog = x44+                         , packageConfigTestMachineLog = x45+                         , packageConfigTestShowDetails = x46+                         , packageConfigTestKeepTix = x47+                         , packageConfigTestWrapper = x48+                         , packageConfigTestFailWhenNoTestSuites = x49+                         , packageConfigTestTestOptions = x51+                         , packageConfigBenchmarkOptions = x52 } =+      [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00'+                      , packageConfigProgramArgs = postShrink_Args x01'+                      , packageConfigProgramPathExtra = x02'+                      , packageConfigFlagAssignment = x03'+                      , packageConfigVanillaLib = x04'+                      , packageConfigSharedLib = x05'+                      , packageConfigStaticLib = x42'+                      , packageConfigDynExe = x06'+                      , packageConfigFullyStaticExe = x50'+                      , packageConfigProf = x07'+                      , packageConfigProfLib = x08'+                      , packageConfigProfExe = x09'+                      , packageConfigProfDetail = x10'+                      , packageConfigProfLibDetail = x11'+                      , packageConfigConfigureArgs = map getNonEmpty x12'+                      , packageConfigOptimization = x13'+                      , packageConfigProgPrefix = x14'+                      , packageConfigProgSuffix = x15'+                      , packageConfigExtraLibDirs = map getNonEmpty x16'+                      , packageConfigExtraLibDirsStatic = map getNonEmpty x53'+                      , packageConfigExtraFrameworkDirs = map getNonEmpty x17'+                      , packageConfigExtraIncludeDirs = map getNonEmpty x18'+                      , packageConfigGHCiLib = x19'+                      , packageConfigSplitSections = x20'+                      , packageConfigSplitObjs = x20_1'+                      , packageConfigStripExes = x21'+                      , packageConfigStripLibs = x22'+                      , packageConfigTests = x23'+                      , packageConfigBenchmarks = x24'+                      , packageConfigCoverage = x25'+                      , packageConfigRelocatable = x26'+                      , packageConfigDebugInfo = x27'+                      , packageConfigDumpBuildInfo = x27_1'+                      , packageConfigRunTests = x28'+                      , packageConfigDocumentation = x29'+                      , packageConfigHaddockHoogle = x30'+                      , packageConfigHaddockHtml = x31'+                      , packageConfigHaddockHtmlLocation = x32'+                      , packageConfigHaddockForeignLibs = x33'+                      , packageConfigHaddockExecutables = x33_1'+                      , packageConfigHaddockTestSuites = x34'+                      , packageConfigHaddockBenchmarks = x35'+                      , packageConfigHaddockInternal = x36'+                      , packageConfigHaddockCss = fmap getNonEmpty x37'+                      , packageConfigHaddockLinkedSource = x38'+                      , packageConfigHaddockQuickJump = x43'+                      , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'+                      , packageConfigHaddockContents = x40'+                      , packageConfigHaddockForHackage = x41'+                      , packageConfigTestHumanLog = x44'+                      , packageConfigTestMachineLog = x45'+                      , packageConfigTestShowDetails = x46'+                      , packageConfigTestKeepTix = x47'+                      , packageConfigTestWrapper = x48'+                      , packageConfigTestFailWhenNoTestSuites = x49'+                      , packageConfigTestTestOptions = x51'+                      , packageConfigBenchmarkOptions = x52' }+      |  (((x00', x01', x02', x03', x04'),+          (x05', x42', x06', x50', x07', x08', x09'),+          (x10', x11', x12', x13', x14'),+          (x15', x16', x53', x17', x18', x19')),+         ((x20', x20_1', x21', x22', x23', x24'),+          (x25', x26', x27', x27_1', x28', x29'),+          (x30', x31', x32', (x33', x33_1'), x34'),+          (x35', x36', x37', x38', x43', x39'),+          (x40', x41'),+          (x44', x45', x46', x47', x48', x49', x51', x52')))+          <- shrink+             (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),+                (x05, x42, x06, x50, x07, x08, x09),+                (x10, x11, map NonEmpty x12, x13, x14),+                (x15, map NonEmpty x16, map NonEmpty x53,+                  map NonEmpty x17,+                  map NonEmpty x18,+                  x19)),+               ((x20, x20_1, x21, x22, x23, x24),+                 (x25, x26, x27, x27_1, x28, x29),+                 (x30, x31, x32, (x33, x33_1), x34),+                 (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39),+                 (x40, x41),+                 (x44, x45, x46, x47, x48, x49, x51, x52)))+      ]+      where+        preShrink_Paths  = Map.map NonEmpty+                         . Map.mapKeys NoShrink+                         . getMapLast+        postShrink_Paths = MapLast+                         . Map.map getNonEmpty+                         . Map.mapKeys getNoShrink+        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)+                         . Map.mapKeys NoShrink+                         . getMapMappend+        postShrink_Args  = MapMappend+                         . Map.map (map getNonEmpty . getNonEmpty)+                         . Map.mapKeys getNoShrink++++instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where+    arbitrary = SourceRepositoryPackage+        <$> arbitrary+        <*> (getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> shortListOf 3 arbitrary)+        <*> (fmap getShortToken <$> shortListOf 3 arbitrary)++    shrink SourceRepositoryPackage {..} = runShrinker $ pure SourceRepositoryPackage+        <*> shrinker srpType+        <*> shrinkerAla ShortToken srpLocation+        <*> shrinkerAla (fmap ShortToken) srpTag+        <*> shrinkerAla (fmap ShortToken) srpBranch+        <*> shrinkerAla (fmap ShortToken) srpSubdir+        <*> shrinkerAla (fmap ShortToken) srpCommand++instance Arbitrary RemoteRepo where+    arbitrary =+      RemoteRepo+        <$> arbitrary+        <*> arbitrary  -- URI+        <*> arbitrary+        <*> listOf arbitraryRootKey+        <*> fmap getNonNegative arbitrary+        <*> pure False+      where+        arbitraryRootKey =+          shortListOf1 5 (oneof [ choose ('0', '9')+                                , choose ('a', 'f') ])++instance Arbitrary LocalRepo where+    arbitrary = LocalRepo+        <$> arbitrary+        <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths+        <*> arbitrary++instance Arbitrary PreSolver where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary ReorderGoals where+    arbitrary = ReorderGoals <$> arbitrary++instance Arbitrary CountConflicts where+    arbitrary = CountConflicts <$> arbitrary++instance Arbitrary FineGrainedConflicts where+    arbitrary = FineGrainedConflicts <$> arbitrary++instance Arbitrary MinimizeConflictSet where+    arbitrary = MinimizeConflictSet <$> arbitrary++instance Arbitrary IndependentGoals where+    arbitrary = IndependentGoals <$> arbitrary++instance Arbitrary StrongFlags where+    arbitrary = StrongFlags <$> arbitrary++instance Arbitrary AllowBootLibInstalls where+    arbitrary = AllowBootLibInstalls <$> arbitrary++instance Arbitrary OnlyConstrained where+    arbitrary = oneof [ pure OnlyConstrainedAll+                      , pure OnlyConstrainedNone+                      ]
+ tests/UnitTests/Distribution/Client/ProjectPlanning.hs view
@@ -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")
+ tests/UnitTests/Distribution/Client/Store.hs view
@@ -0,0 +1,181 @@+module UnitTests.Distribution.Client.Store (tests) where++--import Control.Monad+--import Control.Concurrent (forkIO, threadDelay)+--import Control.Concurrent.MVar+import qualified Data.Set as Set+import System.FilePath+import System.Directory+--import System.Random++import Distribution.Package (UnitId, mkUnitId)+import Distribution.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.Version  (mkVersion)+import Distribution.Verbosity (Verbosity, silent)+import Distribution.Simple.Utils (withTempDirectory)++import Distribution.Client.Store+import Distribution.Client.RebuildMonad++import Test.Tasty+import Test.Tasty.HUnit+++tests :: [TestTree]+tests =+  [ testCase "list content empty"  testListEmpty+  , testCase "install serial"      testInstallSerial+--, testCase "install parallel"    testInstallParallel+    --TODO: figure out some way to do a parallel test, see issue below+  ]+++testListEmpty :: Assertion+testListEmpty =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")++    assertStoreEntryExists storeDirLayout compid unitid False+    assertStoreContent tmp storeDirLayout compid        Set.empty+  where+    compid = CompilerId GHC (mkVersion [1,0])+    unitid = mkUnitId "foo-1.0-xyz"+++testInstallSerial :: Assertion+testInstallSerial =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")+        copyFiles file content dir = do+          -- we copy into a prefix inside the tmp dir and return the prefix+          let destprefix = dir </> "prefix"+          createDirectory destprefix+          writeFile (destprefix </> file) content+          return (destprefix,[])++    assertNewStoreEntry tmp storeDirLayout compid unitid1+                        (copyFiles "file1" "content-foo") (return ())+                        UseNewStoreEntry++    assertNewStoreEntry tmp storeDirLayout compid unitid1+                        (copyFiles "file1" "content-foo") (return ())+                        UseExistingStoreEntry++    assertNewStoreEntry tmp storeDirLayout compid unitid2+                        (copyFiles "file2" "content-bar") (return ())+                        UseNewStoreEntry++    let pkgDir :: UnitId -> FilePath+        pkgDir = storePackageDirectory storeDirLayout compid+    assertFileEqual (pkgDir unitid1 </> "file1") "content-foo"+    assertFileEqual (pkgDir unitid2 </> "file2") "content-bar"+  where+    compid  = CompilerId GHC (mkVersion [1,0])+    unitid1 = mkUnitId "foo-1.0-xyz"+    unitid2 = mkUnitId "bar-2.0-xyz"+++{-+-- unfortunately a parallel test like the one below is thwarted by the normal+-- process-internal file locking. If that locking were not in place then we+-- ought to get the blocking behaviour, but due to the normal Handle locking+-- it just fails instead.++testInstallParallel :: Assertion+testInstallParallel =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")++    sync1 <- newEmptyMVar+    sync2 <- newEmptyMVar+    outv  <- newEmptyMVar+    regv  <- newMVar (0 :: Int)++    sequence_+      [ do forkIO $ do+             let copyFiles dir = do+                   delay <- randomRIO (1,100000)+                   writeFile (dir </> "file") (show n)+                   putMVar  sync1 ()+                   readMVar sync2+                   threadDelay delay+                 register = do+                   modifyMVar_ regv (return . (+1))+                   threadDelay 200000+             o <- newStoreEntry verbosity storeDirLayout+                                compid unitid+                                copyFiles register+             putMVar outv (n, o)+      | n <- [0..9 :: Int] ]++    replicateM_ 10 (takeMVar sync1)+    -- all threads are in the copyFiles action concurrently, release them:+    putMVar  sync2 ()++    outcomes <- replicateM 10 (takeMVar outv)+    regcount <- readMVar regv+    let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ]++    assertEqual "num registrations" 1 regcount+    assertEqual "num registrations" 1 regcount'++    assertStoreContent tmp storeDirLayout compid (Set.singleton unitid)++    let pkgDir :: UnitId -> FilePath+        pkgDir = storePackageDirectory storeDirLayout compid+    case [ n | (n, UseNewStoreEntry) <- outcomes ] of+      [n] -> assertFileEqual (pkgDir unitid </> "file") (show n)+      _   -> assertFailure "impossible"++  where+    compid  = CompilerId GHC (mkVersion [1,0])+    unitid = mkUnitId "foo-1.0-xyz"+-}++-------------+-- Utils++assertNewStoreEntry :: FilePath -> StoreDirLayout+                    -> CompilerId -> UnitId+                    -> (FilePath -> IO (FilePath,[FilePath])) -> IO ()+                    -> NewStoreEntryOutcome+                    -> Assertion+assertNewStoreEntry tmp storeDirLayout compid unitid+                    copyFiles register expectedOutcome = do+    entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid+    outcome <- newStoreEntry verbosity storeDirLayout+                             compid unitid+                             copyFiles register+    assertEqual "newStoreEntry outcome" expectedOutcome outcome+    assertStoreEntryExists storeDirLayout compid unitid True+    let expected = Set.insert unitid entries+    assertStoreContent tmp storeDirLayout compid expected+++assertStoreEntryExists :: StoreDirLayout+                       -> CompilerId -> UnitId -> Bool+                       -> Assertion+assertStoreEntryExists storeDirLayout compid unitid expected = do+    actual <- doesStoreEntryExist storeDirLayout compid unitid+    assertEqual "store entry exists" expected actual+++assertStoreContent :: FilePath -> StoreDirLayout+                   -> CompilerId -> Set.Set UnitId+                   -> Assertion+assertStoreContent tmp storeDirLayout compid expected = do+    actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid+    assertEqual "store content" actual expected+++assertFileEqual :: FilePath -> String -> Assertion+assertFileEqual path expected = do+    exists <- doesFileExist path+    assertBool ("file does not exist:\n" ++ path) exists+    actual <- readFile path+    assertEqual ("file content for:\n" ++ path) expected actual+++verbosity :: Verbosity+verbosity = silent+
+ tests/UnitTests/Distribution/Client/Tar.hs view
@@ -0,0 +1,78 @@+module UnitTests.Distribution.Client.Tar (+  tests+  ) where++import Distribution.Client.Tar ( filterEntries+                               , filterEntriesM+                               )+import Codec.Archive.Tar       ( Entries(..)+                               , foldEntries+                               )+import Codec.Archive.Tar.Entry ( EntryContent(..)+                               , simpleEntry+                               , Entry(..)+                               , toTarPath+                               )++import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Control.Monad.Writer.Lazy (runWriterT, tell)++tests :: [TestTree]+tests = [ testCase "filterEntries" filterTest+        , testCase "filterEntriesM" filterMTest+        ]++filterTest :: Assertion+filterTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let str = BS.Char8.unpack $ case entryContent e of+                       NormalFile dta _ -> dta+                       _                -> error "Invalid entryContent"+                 in str /= "y")+  assertEqual "Unexpected result for filter" "xz" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filter" "z" $+    entriesToString $ filterEntries p $ Done+  assertEqual "Unexpected result for filter" "xf" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f"++filterMTest :: Assertion+filterMTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let str = BS.Char8.unpack $ case entryContent e of+                       NormalFile dta _ -> dta+                       _                -> error "Invalid entryContent"+                 in tell "t" >> return (str /= "y"))++  (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filterM" "xz" $ entriesToString r+  assertEqual "Unexpected result for filterM w" "tt" w++  (r1, w1) <- runWriterT $ filterEntriesM p $ Done+  assertEqual "Unexpected result for filterM" "z" $ entriesToString r1+  assertEqual "Unexpected result for filterM w" "" w1++  (r2, w2) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 $ Fail "f"+  assertEqual "Unexpected result for filterM" "xf" $ entriesToString r2+  assertEqual "Unexpected result for filterM w" "tt" w2++getFileEntry :: FilePath -> [Char] -> Entry+getFileEntry pth dta =+  simpleEntry tp $ NormalFile dta' $ BS.length dta'+  where  tp = case toTarPath False pth of+           Right tp' -> tp'+           Left e -> error e+         dta' = BS.Char8.pack dta++entriesToString :: Entries String -> String+entriesToString =+  foldEntries (\e acc -> let str = BS.Char8.unpack $ case entryContent e of+                               NormalFile dta _ -> dta+                               _                -> error "Invalid entryContent"+                          in str ++ acc) "z" id
+ tests/UnitTests/Distribution/Client/Targets.hs view
@@ -0,0 +1,104 @@+module UnitTests.Distribution.Client.Targets (+  tests+  ) where++import Distribution.Client.Targets     (UserQualifier(..)+                                       ,UserConstraintScope(..)+                                       ,UserConstraint(..), readUserConstraint)+import Distribution.Package            (mkPackageName)+import Distribution.PackageDescription (mkFlagName, mkFlagAssignment)+import Distribution.Version            (anyVersion, thisVersion, mkVersion)++import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList)++import Distribution.Solver.Types.PackageConstraint (PackageProperty(..))+import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..))++import Test.Tasty+import Test.Tasty.HUnit++import Data.List                       (intercalate)++-- Helper function: makes a test group by mapping each element+-- of a list to a test case.+makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree+makeGroup name f xs = testGroup name $+                      zipWith testCase (map show [0 :: Integer ..]) (map f xs)++tests :: [TestTree]+tests =+  [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest)+      exampleConstraints++  , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest)+      exampleConstraints++  , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest)+      [-- First example only.+       (head exampleStrs, take 1 exampleUcs),+       -- All examples separated by commas.+       (intercalate ", " exampleStrs, exampleUcs)]+  ]+  where+    (exampleStrs, exampleUcs) = unzip exampleConstraints++exampleConstraints :: [(String, UserConstraint)]+exampleConstraints =+  [ ("template-haskell installed",+     UserConstraint (UserQualified UserQualToplevel (pn "template-haskell"))+                    PackagePropertyInstalled)++  , ("bytestring >= 0",+     UserConstraint (UserQualified UserQualToplevel (pn "bytestring"))+                    (PackagePropertyVersion anyVersion))++  , ("any.directory test",+     UserConstraint (UserAnyQualifier (pn "directory"))+                    (PackagePropertyStanzas [TestStanzas]))++  , ("setup.Cabal installed",+     UserConstraint (UserAnySetupQualifier (pn "Cabal"))+                    PackagePropertyInstalled)++  , ("process:setup.bytestring ==5.2",+     UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))+                    (PackagePropertyVersion (thisVersion (mkVersion [5, 2]))))++    -- flag MUST be prefixed with - or ++  , ("network:setup.containers +foo -bar +baz",+     UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers"))+                    (PackagePropertyFlags (mkFlagAssignment+                                          [(fn "foo", True),+                                           (fn "bar", False),+                                           (fn "baz", True)])))++  -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.+  --+  -- , ("foo:happy:exe.template-haskell test",+  --    UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))+  --                   (PackagePropertyStanzas [TestStanzas]))+  ]+  where+    pn = mkPackageName+    fn = mkFlagName++readUserConstraintTest :: String -> UserConstraint -> Assertion+readUserConstraintTest str uc =+  assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual+  where+    expected = Right uc+    actual   = readUserConstraint str++parseUserConstraintTest :: String -> UserConstraint -> Assertion+parseUserConstraintTest str uc =+  assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual+  where+    expected = Right uc+    actual   = explicitEitherParsec parsec str++readUserConstraintsTest :: String -> [UserConstraint] -> Assertion+readUserConstraintsTest str ucs =+  assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual+  where+    expected = Right ucs+    actual   = explicitEitherParsec (parsecCommaList parsec) str
+ tests/UnitTests/Distribution/Client/TreeDiffInstances.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.TreeDiffInstances () where++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.Settings++import Distribution.Client.BuildReports.Types+import Distribution.Client.CmdInstall.ClientInstallFlags+import Distribution.Client.Dependency.Types+import Distribution.Client.IndexUtils.ActiveRepos+import Distribution.Client.IndexUtils.IndexState+import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.ProjectConfig.Types+import Distribution.Client.Targets+import Distribution.Client.Types+import Distribution.Client.Types.OverwritePolicy         (OverwritePolicy)+import Distribution.Client.Types.SourceRepo              (SourceRepositoryPackage)++import Distribution.Simple.Compiler                      (PackageDB)++import Data.TreeDiff.Class+import Data.TreeDiff.Instances.Cabal ()+import Network.URI++instance (ToExpr k, ToExpr v) => ToExpr (MapMappend k v)+instance (ToExpr k, ToExpr v) => ToExpr (MapLast k v)++instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f)++instance ToExpr ActiveRepoEntry+instance ToExpr ActiveRepos+instance ToExpr AllowBootLibInstalls+instance ToExpr AllowNewer+instance ToExpr AllowOlder+instance ToExpr BuildReport+instance ToExpr ClientInstallFlags+instance ToExpr CombineStrategy+instance ToExpr ConstraintSource+instance ToExpr CountConflicts+instance ToExpr FineGrainedConflicts+instance ToExpr IndependentGoals+instance ToExpr InstallMethod+instance ToExpr InstallOutcome+instance ToExpr LocalRepo+instance ToExpr MinimizeConflictSet+instance ToExpr OnlyConstrained+instance ToExpr OptionalStanza+instance ToExpr Outcome+instance ToExpr OverwritePolicy+instance ToExpr PackageConfig+instance ToExpr PackageDB+instance ToExpr PackageProperty+instance ToExpr PreSolver+instance ToExpr ProjectConfig+instance ToExpr ProjectConfigBuildOnly+instance ToExpr ProjectConfigProvenance+instance ToExpr ProjectConfigShared+instance ToExpr RelaxDepMod+instance ToExpr RelaxDeps+instance ToExpr RelaxDepScope+instance ToExpr RelaxDepSubject+instance ToExpr RelaxedDep+instance ToExpr RemoteRepo+instance ToExpr ReorderGoals+instance ToExpr RepoIndexState+instance ToExpr RepoName+instance ToExpr ReportLevel+instance ToExpr StrongFlags+instance ToExpr Timestamp+instance ToExpr TotalIndexState+instance ToExpr UserConstraint+instance ToExpr UserConstraintScope+instance ToExpr UserQualifier+instance ToExpr WriteGhcEnvironmentFilesPolicy++instance ToExpr URI+instance ToExpr URIAuth
+ tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+module UnitTests.Distribution.Client.UserConfig+    ( tests+    ) where++import Control.Exception (bracket)+import Control.Monad (replicateM_)+import Data.List (sort, nub)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+import System.Directory (doesFileExist,+                         getCurrentDirectory, getTemporaryDirectory)+import System.FilePath ((</>))++import Test.Tasty+import Test.Tasty.HUnit++import Distribution.Client.Config+import Distribution.Utils.NubList (fromNubList)+import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))+import Distribution.Client.Utils (removeExistingFile)+import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag)+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)++tests :: [TestTree]+tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest+        , testCase "canDetectDifference" canDetectDifference+        , testCase "canUpdateConfig" canUpdateConfig+        , testCase "doubleUpdateConfig" doubleUpdateConfig+        , testCase "newDefaultConfig" newDefaultConfig+        ]++nullDiffOnCreateTest :: Assertion+nullDiffOnCreateTest = bracketTest $ \configFile -> do+    -- Create a new default config file in our test directory.+    _ <- createDefaultConfigFile silent [] configFile+    -- Now we read it in and compare it against the default.+    diff <- userConfigDiff silent (globalFlags configFile) []+    assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff+++canDetectDifference :: Assertion+canDetectDifference = bracketTest $ \configFile -> do+    -- Create a new default config file in our test directory.+    _ <- createDefaultConfigFile silent [] configFile+    appendFile configFile "verbose: 0\n"+    diff <- userConfigDiff silent (globalFlags configFile) []+    assertBool (unlines $ "Should detect a difference:" : diff) $+        diff == [ "+ verbose: 0" ]+++canUpdateConfig :: Assertion+canUpdateConfig = bracketTest $ \configFile -> do+    -- Write a trivial cabal file.+    writeFile configFile "tests: True\n"+    -- Update the config file.+    userConfigUpdate silent (globalFlags configFile) []+    -- Load it again.+    updated <- loadConfig silent (Flag configFile)+    assertBool ("Field 'tests' should be True") $+        fromFlag (configTests $ savedConfigureFlags updated)+++doubleUpdateConfig :: Assertion+doubleUpdateConfig = bracketTest $ \configFile -> do+    -- Create a new default config file in our test directory.+    _ <- createDefaultConfigFile silent [] configFile+    -- Update it twice.+    replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) []+    -- Load it again.+    updated <- loadConfig silent (Flag configFile)++    assertBool ("Field 'remote-repo' doesn't contain duplicates") $+        listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)+    assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $+        listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)+    assertBool ("Field 'build-summary' doesn't contain duplicates") $+        listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)+++newDefaultConfig :: Assertion+newDefaultConfig = do+    sysTmpDir <- getTemporaryDirectory+    withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do+        let configFile  = tmpDir </> "tmp.config"+        _ <- createDefaultConfigFile silent [] configFile+        exists <- doesFileExist configFile+        assertBool ("Config file should be written to " ++ configFile) exists+++globalFlags :: FilePath -> GlobalFlags+globalFlags configFile = mempty { globalConfigFile = Flag configFile }+++listUnique :: Ord a => [a] -> Bool+listUnique xs =+    let sorted = sort xs+    in nub sorted == xs+++bracketTest :: (FilePath -> IO ()) -> Assertion+bracketTest =+    bracket testSetup testTearDown+  where+    testSetup :: IO FilePath+    testSetup = fmap (</> "test-user-config") getCurrentDirectory++    testTearDown :: FilePath -> IO ()+    testTearDown configFile =+        mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
+ tests/UnitTests/Distribution/Client/VCS.hs view
@@ -0,0 +1,947 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns, KindSignatures, DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-}+module UnitTests.Distribution.Client.VCS (tests) where++import Distribution.Client.Compat.Prelude+import Distribution.Client.VCS+import Distribution.Client.RebuildMonad+         ( execRebuild )+import Distribution.Simple.Program+import Distribution.System ( buildOS, OS (Windows) )+import Distribution.Verbosity as Verbosity+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy)++import Data.List (mapAccumL)+import Data.Tuple+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Control.Monad.State as State+import Control.Monad.State (StateT, liftIO, execStateT)+import Control.Exception+import Control.Concurrent (threadDelay)++import System.IO+import System.FilePath+import System.Directory+import System.Random++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.ExpectedFailure+import UnitTests.Distribution.Client.ArbitraryInstances+import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack)+++-- | These tests take the following approach: we generate a pure representation+-- of a repository plus a corresponding real repository, and then run various+-- test operations and compare the actual working state with the expected+-- working state.+--+-- The first test simply checks that the test infrastructure works. It+-- constructs a repository on disk and then checks out every tag or commit+-- and checks that the working state is the same as the pure representation.+--+-- The second test works in a similar way but tests 'syncSourceRepos'. It+-- uses an arbitrary source repo and a set of (initially empty) destination+-- directories. It picks a number of tags or commits from the source repo and+-- synchronises the destination directories to those target states, and then+-- checks that the working state is as expected (given the pure representation).+--+tests :: MTimeChange -> [TestTree]+tests mtimeChange = map (localOption $ QuickCheckTests 10)+  [ ignoreInWindows "See issue #8048" $+    testGroup "git"+    [ testProperty "check VCS test framework"    prop_framework_git+    , testProperty "cloneSourceRepo"             prop_cloneRepo_git+    , testProperty "syncSourceRepos"             prop_syncRepos_git+    ]++    --+  , ignoreTestBecause "for the moment they're not yet working" $+    testGroup "darcs"+    [ testProperty "check VCS test framework"    $ prop_framework_darcs mtimeChange+    , testProperty "cloneSourceRepo"             $ prop_cloneRepo_darcs mtimeChange+    , testProperty "syncSourceRepos"             $ prop_syncRepos_darcs mtimeChange+    ]++  , ignoreTestBecause "for the moment they're not yet working" $+    testGroup "pijul"+    [ testProperty "check VCS test framework"    prop_framework_pijul+    , testProperty "cloneSourceRepo"             prop_cloneRepo_pijul+    , testProperty "syncSourceRepos"             prop_syncRepos_pijul+    ]++  , ignoreTestBecause "for the moment they're not yet working" $+    testGroup "mercurial"+    [ testProperty "check VCS test framework"    prop_framework_hg+    , testProperty "cloneSourceRepo"             prop_cloneRepo_hg+    , testProperty "syncSourceRepos"             prop_syncRepos_hg+    ]++  ]++  where ignoreInWindows msg =  case buildOS of+          Windows -> ignoreTestBecause msg+          _       -> id++prop_framework_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property+prop_framework_git =+    ioProperty+  . prop_framework vcsGit vcsTestDriverGit+  . WithBranchingSupport++prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_framework_darcs mtimeChange =+    ioProperty+  . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)+  . WithoutBranchingSupport++prop_framework_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_framework_pijul =+    ioProperty+  . prop_framework vcsPijul vcsTestDriverPijul+  . WithBranchingSupport++prop_framework_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_framework_hg =+    ioProperty+  . prop_framework vcsHg vcsTestDriverHg+  . WithBranchingSupport++prop_cloneRepo_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property+prop_cloneRepo_git =+    ioProperty+  . prop_cloneRepo vcsGit vcsTestDriverGit+  . WithBranchingSupport++prop_cloneRepo_darcs :: MTimeChange+                     -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_cloneRepo_darcs mtimeChange =+    ioProperty+  . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)+  . WithoutBranchingSupport++prop_cloneRepo_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_cloneRepo_pijul =+    ioProperty+  . prop_cloneRepo vcsPijul vcsTestDriverPijul+  . WithBranchingSupport++prop_cloneRepo_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_cloneRepo_hg =+    ioProperty+  . prop_cloneRepo vcsHg vcsTestDriverHg+  . WithBranchingSupport++prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed+                   -> BranchingRepoRecipe 'SubmodulesSupported  -> Property+prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =+    ioProperty+  . prop_syncRepos vcsGit vcsTestDriverGit+                   destRepoDirs syncTargetSetIterations seed+  . WithBranchingSupport++prop_syncRepos_darcs :: MTimeChange+                     -> RepoDirSet -> SyncTargetIterations -> PrngSeed+                     -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_syncRepos_darcs  mtimeChange destRepoDirs syncTargetSetIterations seed =+    ioProperty+  . prop_syncRepos vcsDarcs (vcsTestDriverDarcs mtimeChange)+                   destRepoDirs syncTargetSetIterations seed+  . WithoutBranchingSupport++prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed+                   -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =+    ioProperty+  . prop_syncRepos vcsPijul vcsTestDriverPijul+                   destRepoDirs syncTargetSetIterations seed+  . WithBranchingSupport++prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed+                   -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property+prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed =+    ioProperty+  . prop_syncRepos vcsHg vcsTestDriverHg+                   destRepoDirs syncTargetSetIterations seed+  . WithBranchingSupport++-- ------------------------------------------------------------+-- * General test setup+-- ------------------------------------------------------------++testSetup :: VCS Program+          -> (Verbosity -> VCS ConfiguredProgram+                        -> FilePath -> FilePath -> VCSTestDriver)+          -> RepoRecipe submodules+          -> (VCSTestDriver -> FilePath -> RepoState -> IO a)+          -> IO a+testSetup vcs mkVCSTestDriver repoRecipe theTest = do+    -- test setup+    vcs' <- configureVCS verbosity vcs+    withTestDir verbosity "vcstest" $ \tmpdir -> do+      let srcRepoPath = tmpdir </> "src"+          submodulesPath = tmpdir </> "submodules"+          vcsDriver   = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath+      repoState <- createRepo vcsDriver repoRecipe++      -- actual test+      result <- theTest vcsDriver tmpdir repoState++      return result+  where+    verbosity = silent++-- ------------------------------------------------------------+-- * Test 1: VCS infrastructure+-- ------------------------------------------------------------++-- | This test simply checks that the test infrastructure works. It constructs+-- a repository on disk and then checks out every tag or commit and checks that+-- the working state is the same as the pure representation.+--+prop_framework :: VCS Program+               -> (Verbosity -> VCS ConfiguredProgram+                             -> FilePath -> FilePath -> VCSTestDriver)+               -> RepoRecipe submodules+               -> IO ()+prop_framework vcs mkVCSTestDriver repoRecipe =+    testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->+      mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))+  where+    -- Check for any given tag/commit in the 'RepoState' that the working state+    -- matches the actual working state from the repository at that tag/commit.+    checkAtTag VCSTestDriver {..} tmpdir (tagname, expectedState) =+      case vcsCheckoutTag of+        -- We handle two cases: inplace checkouts for VCSs that support it+        -- (e.g. git) and separate dir otherwise (e.g. darcs)+        Left checkoutInplace -> do+          checkoutInplace tagname+          checkExpectedWorkingState vcsIgnoreFiles vcsRepoRoot expectedState++        Right checkoutCloneTo -> do+          checkoutCloneTo tagname destRepoPath+          checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState+          removeDirectoryRecursiveHack silent destRepoPath+        where+          destRepoPath = tmpdir </> "dest"+++-- ------------------------------------------------------------+-- * Test 2: 'cloneSourceRepo'+-- ------------------------------------------------------------++prop_cloneRepo :: VCS Program+               -> (Verbosity -> VCS ConfiguredProgram+                             -> FilePath -> FilePath -> VCSTestDriver)+               -> RepoRecipe submodules+               -> IO ()+prop_cloneRepo vcs mkVCSTestDriver repoRecipe =+    testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->+      mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))+  where+    checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = do+        cloneSourceRepo verbosity vcsVCS repo destRepoPath+        checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState+        removeDirectoryRecursiveHack verbosity destRepoPath+      where+        destRepoPath = tmpdir </> "dest"+        repo = SourceRepositoryPackage+            { srpType     = vcsRepoType vcsVCS+            , srpLocation = vcsRepoRoot+            , srpTag      = Just tagname+            , srpBranch   = Nothing+            , srpSubdir   = []+            , srpCommand  = []+            }+    verbosity = silent+++-- ------------------------------------------------------------+-- * Test 3: 'syncSourceRepos'+-- ------------------------------------------------------------++newtype RepoDirSet           = RepoDirSet Int           deriving Show+newtype SyncTargetIterations = SyncTargetIterations Int deriving Show+newtype PrngSeed             = PrngSeed Int             deriving Show++prop_syncRepos :: VCS Program+               -> (Verbosity -> VCS ConfiguredProgram+                             -> FilePath -> FilePath -> VCSTestDriver)+               -> RepoDirSet+               -> SyncTargetIterations+               -> PrngSeed+               -> RepoRecipe submodules+               -> IO ()+prop_syncRepos vcs mkVCSTestDriver+               repoDirs syncTargetSetIterations seed repoRecipe =+    testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->+      let srcRepoPath   = vcsRepoRoot vcsDriver+          destRepoPaths = map (tmpdir </>) (getRepoDirs repoDirs)+       in checkSyncRepos verbosity vcsDriver repoState+                         srcRepoPath destRepoPaths+                         syncTargetSetIterations seed+  where+    verbosity = silent++    getRepoDirs :: RepoDirSet -> [FilePath]+    getRepoDirs (RepoDirSet n) =+        [ "dest" ++ show i | i <- [1..n] ]+++-- | The purpose of this test is to check that irrespective of the local cached+-- repo dir we can sync it to an arbitrary target state. So we do that by+-- syncing each target dir to a sequence of target states without cleaning it+-- in between.+--+-- One slight complication is that 'syncSourceRepos' takes a whole list of+-- target dirs to sync in one go (to allow for sharing). So we must actually+-- generate and sync to a sequence of list of target repo states.+--+-- So, given a source repo dir, the corresponding 'RepoState' and a number of+-- target repo dirs, pick a sequence of (lists of) sync targets from the+-- 'RepoState' and syncronise the target dirs with those targets, checking for+-- each one that the actual working state matches the expected repo state.+--+checkSyncRepos+  :: Verbosity+  -> VCSTestDriver+  -> RepoState+  -> FilePath+  -> [FilePath]+  -> SyncTargetIterations+  -> PrngSeed+  -> IO ()+checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles }+               repoState srcRepoPath destRepoPath+               (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) =+    mapM_ checkSyncTargetSet syncTargetSets+  where+    checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO ()+    checkSyncTargetSet syncTargets = do+      _ <- execRebuild "root-unused" $+           syncSourceRepos verbosity vcs+                           [ (repo, repoPath)+                           | (repo, repoPath, _) <- syncTargets ]+      sequence_+        [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState+        | (_, repoPath, workingState) <- syncTargets ]++    syncTargetSets = take syncTargetSetIterations+                   $ pickSyncTargetSets (vcsRepoType vcs) repoState+                                        srcRepoPath destRepoPath+                                        (mkStdGen seed)++pickSyncTargetSets :: RepoType -> RepoState+                   -> FilePath -> [FilePath]+                   -> StdGen+                   -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]]+pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =+    assert (Map.size (allTags repoState) > 0) $+    unfoldr (Just . swap . pickSyncTargetSet)+  where+    pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)]+    pickSyncTargetSet = flip (mapAccumL (flip pickSyncTarget)) dstReposPath++    pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState)+    pickSyncTarget destRepoPath prng =+        (prng', (repo, destRepoPath, workingState))+      where+        repo                = SourceRepositoryPackage+                              { srpType     = repoType+                              , srpLocation = srcRepoPath+                              , srpTag      = Just tag+                              , srpBranch   = Nothing+                              , srpSubdir   = Proxy+                              , srpCommand  = []+                              }+        (tag, workingState) = Map.elemAt tagIdx (allTags repoState)+        (tagIdx, prng')     = randomR (0, Map.size (allTags repoState) - 1) prng++type Rand a = StdGen -> (StdGen, a)++instance Arbitrary RepoDirSet where+  arbitrary =+    sized $ \n -> oneof $ [ RepoDirSet <$> pure 1 ]+                       ++ [ RepoDirSet <$> choose (2,5) | n >= 3 ]+  shrink (RepoDirSet n) =+    [ RepoDirSet i | i <- shrink n, i > 0 ]++instance Arbitrary SyncTargetIterations where+  arbitrary =+    sized $ \n -> SyncTargetIterations <$> elements [ 1 .. min 20 (n + 1) ]+  shrink (SyncTargetIterations n) =+    [ SyncTargetIterations i | i <- shrink n, i > 0 ]++instance Arbitrary PrngSeed where+  arbitrary = PrngSeed <$> arbitraryBoundedRandom+++-- ------------------------------------------------------------+-- * Instructions for constructing repositories+-- ------------------------------------------------------------++-- These instructions for constructing a repository can be interpreted in two+-- ways: to make a pure representation of repository state, and to execute+-- VCS commands to make a repository on-disk.++data SubmodulesSupport = SubmodulesSupported | SubmodulesNotSupported++class KnownSubmodulesSupport (a :: SubmodulesSupport) where+  submoduleSupport :: SubmodulesSupport++instance KnownSubmodulesSupport 'SubmodulesSupported where+  submoduleSupport = SubmodulesSupported++instance KnownSubmodulesSupport 'SubmodulesNotSupported where+  submoduleSupport = SubmodulesNotSupported++data FileUpdate   = FileUpdate FilePath String+                  deriving Show+data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported)+                  deriving Show++newtype Commit (submodules :: SubmodulesSupport)+  = Commit [Either FileUpdate SubmoduleAdd]+  deriving Show++data TaggedCommits (submodules :: SubmodulesSupport)+  = TaggedCommits TagName    [Commit submodules]+  deriving Show++data BranchCommits (submodules :: SubmodulesSupport)+  = BranchCommits BranchName [Commit submodules]+  deriving Show++type BranchName = String+type TagName    = String++-- | Instructions to make a repository without branches, for VCSs that do not+-- support branches (e.g. darcs).+newtype NonBranchingRepoRecipe submodules+  = NonBranchingRepoRecipe [TaggedCommits submodules]+  deriving Show++-- | Instructions to make a repository with branches, for VCSs that do+-- support branches (e.g. git).+newtype BranchingRepoRecipe submodules+  = BranchingRepoRecipe [Either (TaggedCommits submodules) (BranchCommits submodules)]+ deriving Show++data RepoRecipe submodules+  = WithBranchingSupport       (BranchingRepoRecipe submodules)+  | WithoutBranchingSupport (NonBranchingRepoRecipe submodules)+  deriving Show++-- ---------------------------------------------------------------------------+-- Arbitrary instances for them++genFileName :: Gen FilePath+genFileName = (\c -> "file" </> [c]) <$> choose ('A', 'E')++instance Arbitrary FileUpdate where+  arbitrary = genOnlyFileUpdate+    where+      genOnlyFileUpdate   = FileUpdate <$> genFileName <*> genFileContent+      genFileContent      = vectorOf 10 (choose ('#', '~'))++instance Arbitrary SubmoduleAdd where+  arbitrary = genOnlySubmoduleAdd+    where+      genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary+      genSubmoduleSrc     = vectorOf 20 (choose ('a', 'z'))++instance forall submodules.KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where+  arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd+    where+      fileUpdateOrSubmoduleAdd =+        case submoduleSupport @submodules of+          SubmodulesSupported -> frequency [ (10, Left <$> arbitrary)+                                           , (1, Right <$> arbitrary)+                                           ]+          SubmodulesNotSupported -> Left <$> arbitrary+  shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes)++instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where+  arbitrary = TaggedCommits <$> genTagName <*>  shortListOf1 5 arbitrary+    where+      genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z'))+  shrink (TaggedCommits tag commits) =+    TaggedCommits tag <$> filter (not . null) (shrink commits)++instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodules) where+  arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 5 arbitrary+    where+      genBranchName =+        sized $ \n ->+          (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A'..'E'])++  shrink (BranchCommits branch commits) =+    BranchCommits branch <$> filter (not . null) (shrink commits)++instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe submodules) where+  arbitrary = NonBranchingRepoRecipe <$> shortListOf1 15 arbitrary+  shrink (NonBranchingRepoRecipe xs) =+    NonBranchingRepoRecipe <$> filter (not . null) (shrink xs)++instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where+  arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch+    where+      taggedOrBranch = frequency [ (3, Left  <$> arbitrary)+                                 , (1, Right <$> arbitrary)+                                 ]+  shrink (BranchingRepoRecipe xs) =+    BranchingRepoRecipe <$> filter (not . null) (shrink xs)+++-- ------------------------------------------------------------+-- * A pure model of repository state+-- ------------------------------------------------------------++-- | The full state of a repository. In particular it records the full working+-- state for every tag.+--+-- This is also the interpreter state for executing a 'RepoRecipe'.+--+-- This allows us to compare expected working states with the actual files in+-- the working directory of a repository. See 'checkExpectedWorkingState'.+--+data RepoState =+     RepoState {+       currentBranch  :: BranchName,+       currentWorking :: RepoWorkingState,+       allTags        :: Map TagOrCommitId RepoWorkingState,+       allBranches    :: Map BranchName RepoWorkingState+     }+  deriving Show++type RepoWorkingState = Map FilePath String+type CommitId         = String+type TagOrCommitId    = String+++------------------------------------------------------------------------------+-- Functions used to interpret instructions for constructing repositories++initialRepoState :: RepoState+initialRepoState =+    RepoState {+      currentBranch  = "branch_master",+      currentWorking = Map.empty,+      allTags        = Map.empty,+      allBranches    = Map.empty+    }++updateFile :: FilePath -> String -> RepoState -> RepoState+updateFile filename content state@RepoState{currentWorking} =+  let removeSubmodule = Map.filterWithKey (\path _ -> not $ filename `isPrefixOf` path) currentWorking+  in state { currentWorking = Map.insert filename content removeSubmodule }++addSubmodule :: FilePath -> RepoState -> RepoState -> RepoState+addSubmodule submodulePath submoduleState mainState =+  let newFiles = Map.mapKeys (submodulePath </>) (currentWorking submoduleState)+      removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path ) (currentWorking mainState)+      newWorking = Map.union removeSubmodule newFiles+  in mainState { currentWorking = newWorking}++addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState+addTagOrCommit commit state@RepoState{currentWorking, allTags} =+  state { allTags = Map.insert commit currentWorking allTags }++switchBranch :: BranchName -> RepoState -> RepoState+switchBranch branch state@RepoState{currentWorking, currentBranch, allBranches} =+  -- Use updated allBranches to cover case of switching to the same branch+  let allBranches' = Map.insert currentBranch currentWorking allBranches in+  state {+    currentBranch  = branch,+    currentWorking = case Map.lookup branch allBranches' of+                       Just working -> working+                       -- otherwise we're creating a new branch, which starts+                       -- from our current branch state+                       Nothing      -> currentWorking,+    allBranches    = allBranches'+  }+++-- ------------------------------------------------------------+-- * Comparing on-disk with expected 'RepoWorkingState'+-- ------------------------------------------------------------++-- | Compare expected working states with the actual files in+-- the working directory of a repository.+--+checkExpectedWorkingState :: Set FilePath+                          -> FilePath -> RepoWorkingState -> IO ()+checkExpectedWorkingState ignore repoPath expectedState = do+    currentState <- getCurrentWorkingState ignore repoPath+    unless (currentState == expectedState) $+      throwIO (WorkingStateMismatch expectedState currentState)++data WorkingStateMismatch =+     WorkingStateMismatch RepoWorkingState -- expected+                          RepoWorkingState -- actual+  deriving Show++instance Exception WorkingStateMismatch++getCurrentWorkingState :: Set FilePath -> FilePath -> IO RepoWorkingState+getCurrentWorkingState ignore repoRoot = do+    entries <- getDirectoryContentsRecursive ignore repoRoot ""+    Map.fromList <$> mapM getFileEntry+                          [ file | (file, isDir) <- entries, not isDir ]+  where+   getFileEntry name =+     withBinaryFile (repoRoot </> name) ReadMode $ \h -> do+       str <- hGetContents h+       _   <- evaluate (length str)+       return (name, str)++getDirectoryContentsRecursive :: Set FilePath -> FilePath -> FilePath+                              -> IO [(FilePath, Bool)]+getDirectoryContentsRecursive ignore dir0 dir = do+    entries  <- getDirectoryContents (dir0 </> dir)+    entries' <- sequence+                  [ do isdir <- doesDirectoryExist (dir0 </> dir </> entry)+                       return (dir </> entry, isdir)+                  | entry <- entries+                  , not (isPrefixOf "." entry)+                  , (dir </> entry) `Set.notMember` ignore+                  ]+    let subdirs = [ d | (d, True)  <- entries' ]+    subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs+    return (concat (entries' : subdirEntries))+++-- ------------------------------------------------------------+-- * Executing instructions to make on-disk VCS repos+-- ------------------------------------------------------------++-- | Execute the instructions in a 'RepoRecipe' using the given 'VCSTestDriver'+-- to make an on-disk repository.+--+-- This also returns a 'RepoState'. This is done as part of construction to+-- support VCSs like git that have commit ids, so that those commit ids can be+-- included in the 'RepoState's 'allTags' set.+--+createRepo :: VCSTestDriver -> RepoRecipe submodules -> IO RepoState+createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do+    createDirectoryIfMissing True vcsRepoRoot+    createDirectoryIfMissing True (vcsRepoRoot </> "file")+    vcsInit+    execStateT createRepoAction initialRepoState+  where+    createRepoAction :: StateT RepoState IO ()+    createRepoAction = case recipe of+      WithoutBranchingSupport r -> execNonBranchingRepoRecipe vcsDriver r+      WithBranchingSupport    r -> execBranchingRepoRecipe    vcsDriver r++type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO ()++execNonBranchingRepoRecipe :: CreateRepoAction (NonBranchingRepoRecipe submodules)+execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) =+    mapM_ (execTaggdCommits vcsDriver) taggedCommits++execBranchingRepoRecipe :: CreateRepoAction (BranchingRepoRecipe submodules)+execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) =+    mapM_ (either (execTaggdCommits  vcsDriver)+                  (execBranchCommits vcsDriver))+          taggedCommits++execBranchCommits :: CreateRepoAction (BranchCommits submodules)+execBranchCommits vcsDriver@VCSTestDriver{vcsSwitchBranch}+                  (BranchCommits branch commits) = do+    mapM_ (execCommit vcsDriver) commits+    -- add commits and then switch branch+    State.modify (switchBranch branch)+    state <- State.get -- repo state after the commits and branch switch+    liftIO $ vcsSwitchBranch state branch++    -- It may seem odd that we add commits on the existing branch and then+    -- switch branch. In part this is because git cannot branch from an empty+    -- repo state, it complains that the master branch doesn't exist yet.++execTaggdCommits :: CreateRepoAction (TaggedCommits submodules)+execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState}+                 (TaggedCommits tagname commits) = do+    mapM_ (execCommit vcsDriver) commits+    -- add commits then tag+    state <- State.get -- repo state after the commits+    liftIO $ vcsTagState state tagname+    State.modify (addTagOrCommit tagname)++execCommit :: CreateRepoAction (Commit submodules)+execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do+    mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates+    state <- State.get -- existing state, not updated+    mcommit <- liftIO $ vcsCommitChanges state+    State.modify (maybe id addTagOrCommit mcommit)++execFileUpdate :: CreateRepoAction FileUpdate+execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do+    isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot </> filename)+    liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot </> filename)+    liftIO $ writeFile (vcsRepoRoot </> filename) content+    state <- State.get -- existing state, not updated+    liftIO $ vcsAddFile state filename+    State.modify (updateFile filename content)++execSubmoduleAdd :: CreateRepoAction SubmoduleAdd+execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = do+    submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source+    let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]]+    submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe+    mainState <- State.get -- existing state, not updated+    liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath+    State.modify $ addSubmodule submodulePath submoduleState++-- ------------------------------------------------------------+-- * VCSTestDriver for various VCSs+-- ------------------------------------------------------------++-- | Extends 'VCS' with extra methods to construct a repository. Used by+-- 'createRepo'.+--+-- Several of the methods are allowed to rely on the current 'RepoState'+-- because some VCSs need different commands for initial vs later actions+-- (like adding a file to the tracked set, or creating a new branch).+--+-- The driver instance knows the particular repo directory.+--+data VCSTestDriver = VCSTestDriver {+       vcsVCS             :: VCS ConfiguredProgram,+       vcsRepoRoot        :: FilePath,+       vcsIgnoreFiles     :: Set FilePath,+       vcsInit            :: IO (),+       vcsAddFile         :: RepoState -> FilePath -> IO (),+       vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver,+       vcsAddSubmodule    :: RepoState -> FilePath -> FilePath -> IO (),+       vcsCommitChanges   :: RepoState -> IO (Maybe CommitId),+       vcsTagState        :: RepoState -> TagName -> IO (),+       vcsSwitchBranch    :: RepoState -> BranchName -> IO (),+       vcsCheckoutTag     :: Either (TagName -> IO ())+                                    (TagName -> FilePath -> IO ())+     }+++vcsTestDriverGit :: Verbosity -> VCS ConfiguredProgram+                 -> FilePath -> FilePath -> VCSTestDriver+vcsTestDriverGit verbosity vcs submoduleDir repoRoot =+    VCSTestDriver {+      vcsVCS = vcs++    , vcsRepoRoot = repoRoot++    , vcsIgnoreFiles = Set.empty++    , vcsInit =+        git $ ["init"]  ++ verboseArg++    , vcsAddFile = \_ filename ->+        git ["add", filename]++    , vcsCommitChanges = \_state -> do+        git $ [ "-c", "user.name=A", "-c", "user.email=a@example.com"+              , "commit", "--all", "--message=a patch"+              , "--author=A <a@example.com>"+              ] ++ verboseArg+        commit <- git' ["log", "--format=%H", "-1"]+        let commit' = takeWhile (not . isSpace) commit+        return (Just commit')++    , vcsTagState = \_ tagname ->+        git ["tag", "--force", "--no-sign", tagname]++    , vcsSubmoduleDriver =+        pure . vcsTestDriverGit verbosity vcs submoduleDir . (submoduleDir </>)++    , vcsAddSubmodule = \_ source dest -> do+        destExists <- (||) <$> doesFileExist (repoRoot </> dest)+                           <*> doesDirectoryExist (repoRoot </> dest)+        when destExists $ git ["rm", "-f", dest]+        -- If there is an old submodule git dir with the same name, remove it.+        -- It most likely has a different URL and `git submodule add` will fai.+        submoduleGitDirExists <- doesDirectoryExist $ submoduleGitDir dest+        when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest)+        git ["submodule", "add", source, dest]+        git ["submodule", "update", "--init", "--recursive", "--force"]++    , vcsSwitchBranch = \RepoState{allBranches} branchname -> do+        deinitAndRemoveCachedSubmodules+        unless (branchname `Map.member` allBranches) $+          git ["branch", branchname]+        git $ ["checkout", branchname] ++ verboseArg+        updateSubmodulesAndCleanup++    , vcsCheckoutTag = Left $ \tagname -> do+        deinitAndRemoveCachedSubmodules+        git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg+        updateSubmodulesAndCleanup+    }+  where+    gitInvocation args = (programInvocation (vcsProgram vcs) args) {+                           progInvokeCwd = Just repoRoot+                         }+    git  = runProgramInvocation       verbosity . gitInvocation+    git' = getProgramInvocationOutput verbosity . gitInvocation+    verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]+    submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path+    deinitAndRemoveCachedSubmodules = do+      git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg+      let gitModulesDir = repoRoot </> ".git" </> "modules"+      gitModulesExists <- doesDirectoryExist gitModulesDir+      when gitModulesExists $ removeDirectoryRecursive gitModulesDir+    updateSubmodulesAndCleanup = do+      git $ ["submodule", "sync", "--recursive"] ++ verboseArg+      git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg+      git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]+      git $ ["clean", "-ffxdq"] ++ verboseArg+++type MTimeChange = Int++vcsTestDriverDarcs :: MTimeChange -> Verbosity -> VCS ConfiguredProgram+                   -> FilePath -> FilePath -> VCSTestDriver+vcsTestDriverDarcs mtimeChange verbosity vcs _ repoRoot =+    VCSTestDriver {+      vcsVCS = vcs++    , vcsRepoRoot = repoRoot++    , vcsIgnoreFiles = Set.singleton "_darcs"++    , vcsInit =+        darcs ["initialize"]++    , vcsAddFile = \state filename -> do+        threadDelay mtimeChange+        unless (filename `Map.member` currentWorking state) $+          darcs ["add", filename]+        -- Darcs's file change tracking relies on mtime changes,+        -- so we have to be careful with doing stuff too quickly:++    , vcsSubmoduleDriver = \_->+        fail "vcsSubmoduleDriver: darcs does not support submodules"++    , vcsAddSubmodule = \_ _ _ ->+        fail "vcsAddSubmodule: darcs does not support submodules"++    , vcsCommitChanges = \_state -> do+        threadDelay mtimeChange+        darcs ["record", "--all", "--author=author", "--name=a patch"]+        return Nothing++    , vcsTagState = \_ tagname ->+        darcs ["tag", "--author=author", tagname]++    , vcsSwitchBranch = \_ _ ->+        fail "vcsSwitchBranch: darcs does not support branches within a repo"++    , vcsCheckoutTag = Right $ \tagname dest ->+        darcs ["clone", "--lazy", "--tag=^" ++ tagname ++ "$", ".", dest]+    }+  where+    darcsInvocation args = (programInvocation (vcsProgram vcs) args) {+                               progInvokeCwd = Just repoRoot+                           }+    darcs = runProgramInvocation verbosity . darcsInvocation+++vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram+                   -> FilePath -> FilePath -> VCSTestDriver+vcsTestDriverPijul verbosity vcs _ repoRoot =+    VCSTestDriver {+      vcsVCS = vcs++    , vcsRepoRoot = repoRoot++    , vcsIgnoreFiles = Set.empty++    , vcsInit =+        pijul $ ["init"]++    , vcsAddFile = \_ filename ->+        pijul ["add", filename]++    , vcsSubmoduleDriver = \_ ->+        fail "vcsSubmoduleDriver: pijul does not support submodules"++    , vcsAddSubmodule = \_ _ _ ->+        fail "vcsAddSubmodule: pijul does not support submodules"++    , vcsCommitChanges = \_state -> do+        pijul $ ["record", "-a", "-m 'a patch'"+                , "-A 'A <a@example.com>'"+                ]+        commit <- pijul' ["log"]+        let commit' = takeWhile (not . isSpace) commit+        return (Just commit')++    -- tags work differently in pijul...+    -- so this is wrong+    , vcsTagState = \_ tagname ->+        pijul ["tag", tagname]++    , vcsSwitchBranch = \_ branchname -> do+--        unless (branchname `Map.member` allBranches) $+--          pijul ["from-branch", branchname]+        pijul $ ["checkout", branchname]++    , vcsCheckoutTag = Left $ \tagname ->+        pijul $ ["checkout", tagname]+    }+  where+    gitInvocation args = (programInvocation (vcsProgram vcs) args) {+                           progInvokeCwd = Just repoRoot+                         }+    pijul  = runProgramInvocation       verbosity . gitInvocation+    pijul' = getProgramInvocationOutput verbosity . gitInvocation++vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram+                -> FilePath -> FilePath -> VCSTestDriver+vcsTestDriverHg verbosity vcs _ repoRoot =+    VCSTestDriver {+      vcsVCS = vcs++    , vcsRepoRoot = repoRoot++    , vcsIgnoreFiles = Set.empty++    , vcsInit =+        hg $ ["init"]  ++ verboseArg++    , vcsAddFile = \_ filename ->+        hg ["add", filename]++    , vcsSubmoduleDriver = \_ ->+        fail "vcsSubmoduleDriver: hg submodules not supported"++    , vcsAddSubmodule = \_ _ _ ->+        fail "vcsAddSubmodule: hg submodules not supported"++    , vcsCommitChanges = \_state -> do+        hg $ [ "--user='A <a@example.com>'"+              , "commit", "--message=a patch"+              ] ++ verboseArg+        commit <- hg' ["log", "--template='{node}\\n' -l1"]+        let commit' = takeWhile (not . isSpace) commit+        return (Just commit')++    , vcsTagState = \_ tagname ->+        hg ["tag", "--force", tagname]++    , vcsSwitchBranch = \RepoState{allBranches} branchname -> do+        unless (branchname `Map.member` allBranches) $+          hg ["branch", branchname]+        hg $ ["checkout", branchname] ++ verboseArg++    , vcsCheckoutTag = Left $ \tagname ->+        hg $ ["checkout", "--rev", tagname] ++ verboseArg+    }+  where+    hgInvocation args = (programInvocation (vcsProgram vcs) args) {+                           progInvokeCwd = Just repoRoot+                         }+    hg  = runProgramInvocation       verbosity . hgInvocation+    hg' = getProgramInvocationOutput verbosity . hgInvocation+    verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ tests/UnitTests/Distribution/Solver/Modular/Builder.hs view
@@ -0,0 +1,20 @@+module UnitTests.Distribution.Solver.Modular.Builder (+  tests+  ) where++import Distribution.Solver.Modular.Builder++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testProperty "splitsAltImplementation" splitsTest+        ]++-- | Simpler splits implementation+splits' :: [a] -> [(a, [a])]+splits' [] = []+splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs)++splitsTest :: [Int] -> Property+splitsTest xs = splits' xs === splits xs
+ tests/UnitTests/Distribution/Solver/Modular/DSL.hs view
@@ -0,0 +1,821 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-- | DSL for testing the modular solver+module UnitTests.Distribution.Solver.Modular.DSL (+    ExampleDependency(..)+  , Dependencies(..)+  , ExSubLib(..)+  , ExTest(..)+  , ExExe(..)+  , ExConstraint(..)+  , ExPreference(..)+  , ExampleDb+  , ExampleVersionRange+  , ExamplePkgVersion+  , ExamplePkgName+  , ExampleFlagName+  , ExFlag(..)+  , ExampleAvailable(..)+  , ExampleInstalled(..)+  , ExampleQualifier(..)+  , ExampleVar(..)+  , EnableAllTests(..)+  , dependencies+  , publicDependencies+  , unbuildableDependencies+  , exAv+  , exAvNoLibrary+  , exInst+  , exSubLib+  , exTest+  , exExe+  , exFlagged+  , exResolve+  , extractInstallPlan+  , declareFlags+  , withSubLibrary+  , withSubLibraries+  , withSetupDeps+  , withTest+  , withTests+  , withExe+  , withExes+  , runProgress+  , mkSimpleVersion+  , mkVersionRange+  ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude+import Distribution.Utils.Generic++-- base+import Control.Arrow (second)+import qualified Data.Map as Map+import qualified Distribution.Compat.NonEmptySet as NonEmptySet++-- Cabal+import qualified Distribution.CabalSpecVersion          as C+import qualified Distribution.Compiler                  as C+import qualified Distribution.InstalledPackageInfo      as IPI+import           Distribution.License (License(..))+import qualified Distribution.ModuleName                as Module+import qualified Distribution.Package                   as C+  hiding (HasUnitId(..))+import qualified Distribution.Types.ExeDependency       as C+import qualified Distribution.Types.ForeignLib          as C+import qualified Distribution.Types.LegacyExeDependency as C+import qualified Distribution.Types.LibraryVisibility   as C+import qualified Distribution.Types.PkgconfigDependency as C+import qualified Distribution.Types.PkgconfigVersion    as C+import qualified Distribution.Types.PkgconfigVersionRange as C+import qualified Distribution.Types.UnqualComponentName as C+import qualified Distribution.Types.CondTree            as C+import qualified Distribution.PackageDescription        as C+import qualified Distribution.PackageDescription.Check  as C+import qualified Distribution.Simple.PackageIndex       as C.PackageIndex+import           Distribution.Simple.Setup (BooleanFlag(..))+import qualified Distribution.System                    as C+import           Distribution.Text (display)+import qualified Distribution.Verbosity                 as C+import qualified Distribution.Version                   as C+import qualified Distribution.Utils.Path                as C+import Language.Haskell.Extension (Extension(..), Language(..))++-- cabal-install+import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+import Distribution.Client.Types+import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.Flag+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex      as CI.PackageIndex+import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackagePath as P+import qualified Distribution.Solver.Types.PkgConfigDb as PC+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Variable++{-------------------------------------------------------------------------------+  Example package database DSL++  In order to be able to set simple examples up quickly, we define a very+  simple version of the package database here explicitly designed for use in+  tests.++  The design of `ExampleDb` takes the perspective of the solver, not the+  perspective of the package DB. This makes it easier to set up tests for+  various parts of the solver, but makes the mapping somewhat awkward,  because+  it means we first map from "solver perspective" `ExampleDb` to the package+  database format, and then the modular solver internally in `IndexConversion`+  maps this back to the solver specific data structures.++  IMPLEMENTATION NOTES+  --------------------++  TODO: Perhaps these should be made comments of the corresponding data type+  definitions. For now these are just my own conclusions and may be wrong.++  * The difference between `GenericPackageDescription` and `PackageDescription`+    is that `PackageDescription` describes a particular _configuration_ of a+    package (for instance, see documentation for `checkPackage`). A+    `GenericPackageDescription` can be turned into a `PackageDescription` in+    two ways:++      a. `finalizePD` does the proper translation, by taking+         into account the platform, available dependencies, etc. and picks a+         flag assignment (or gives an error if no flag assignment can be found)+      b. `flattenPackageDescription` ignores flag assignment and just joins all+         components together.++    The slightly odd thing is that a `GenericPackageDescription` contains a+    `PackageDescription` as a field; both of the above functions do the same+    thing: they take the embedded `PackageDescription` as a basis for the result+    value, but override `library`, `executables`, `testSuites`, `benchmarks`+    and `buildDepends`.+  * The `condTreeComponents` fields of a `CondTree` is a list of triples+    `(condition, then-branch, else-branch)`, where the `else-branch` is+    optional.+-------------------------------------------------------------------------------}++type ExamplePkgName    = String+type ExamplePkgVersion = Int+type ExamplePkgHash    = String  -- for example "installed" packages+type ExampleFlagName   = String+type ExampleSubLibName = String+type ExampleTestName   = String+type ExampleExeName    = String+type ExampleVersionRange = C.VersionRange++data Dependencies = Dependencies {+    depsVisibility :: C.LibraryVisibility+  , depsIsBuildable :: Bool+  , depsExampleDependencies :: [ExampleDependency]+  } deriving Show++instance Semigroup Dependencies where+  deps1 <> deps2 = Dependencies {+      depsVisibility = depsVisibility deps1 <> depsVisibility deps2+    , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2+    , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2+    }++instance Monoid Dependencies where+  mempty = Dependencies {+      depsVisibility = mempty+    , depsIsBuildable = True+    , depsExampleDependencies = []+    }+  mappend = (<>)++dependencies :: [ExampleDependency] -> Dependencies+dependencies deps = mempty { depsExampleDependencies = deps }++publicDependencies :: Dependencies+publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic }++unbuildableDependencies :: Dependencies+unbuildableDependencies = mempty { depsIsBuildable = False }++data ExampleDependency =+    -- | Simple dependency on any version+    ExAny ExamplePkgName++    -- | Simple dependency on a fixed version+  | ExFix ExamplePkgName ExamplePkgVersion++    -- | Simple dependency on a range of versions, with an inclusive lower bound+    -- and an exclusive upper bound.+  | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion++    -- | Sub-library dependency+  | ExSubLibAny ExamplePkgName ExampleSubLibName++    -- | Sub-library dependency on a fixed version+  | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion++    -- | Build-tool-depends dependency+  | ExBuildToolAny ExamplePkgName ExampleExeName++    -- | Build-tool-depends dependency on a fixed version+  | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion++    -- | Legacy build-tools dependency+  | ExLegacyBuildToolAny ExamplePkgName++    -- | Legacy build-tools dependency on a fixed version+  | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion++    -- | Dependencies indexed by a flag+  | ExFlagged ExampleFlagName Dependencies Dependencies++    -- | Dependency on a language extension+  | ExExt Extension++    -- | Dependency on a language version+  | ExLang Language++    -- | Dependency on a pkg-config package+  | ExPkg (ExamplePkgName, ExamplePkgVersion)+  deriving Show++-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in+-- example source packages.+data ExFlag = ExFlag {+    exFlagName    :: ExampleFlagName+  , exFlagDefault :: Bool+  , exFlagType    :: FlagType+  } deriving Show++data ExSubLib = ExSubLib ExampleSubLibName Dependencies++data ExTest = ExTest ExampleTestName Dependencies++data ExExe = ExExe ExampleExeName Dependencies++exSubLib :: ExampleSubLibName -> [ExampleDependency] -> ExSubLib+exSubLib name deps = ExSubLib name (dependencies deps)++exTest :: ExampleTestName -> [ExampleDependency] -> ExTest+exTest name deps = ExTest name (dependencies deps)++exExe :: ExampleExeName -> [ExampleDependency] -> ExExe+exExe name deps = ExExe name (dependencies deps)++exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]+          -> ExampleDependency+exFlagged n t e = ExFlagged n (dependencies t) (dependencies e)++data ExConstraint =+    ExVersionConstraint ConstraintScope ExampleVersionRange+  | ExFlagConstraint ConstraintScope ExampleFlagName Bool+  | ExStanzaConstraint ConstraintScope [OptionalStanza]+  deriving Show++data ExPreference =+    ExPkgPref ExamplePkgName ExampleVersionRange+  | ExStanzaPref ExamplePkgName [OptionalStanza]+  deriving Show++data ExampleAvailable = ExAv {+    exAvName    :: ExamplePkgName+  , exAvVersion :: ExamplePkgVersion+  , exAvDeps    :: ComponentDeps Dependencies++  -- Setting flags here is only necessary to override the default values of+  -- the fields in C.Flag.+  , exAvFlags   :: [ExFlag]+  } deriving Show++data ExampleVar =+    P ExampleQualifier ExamplePkgName+  | F ExampleQualifier ExamplePkgName ExampleFlagName+  | S ExampleQualifier ExamplePkgName OptionalStanza++data ExampleQualifier =+    QualNone+  | QualIndep ExamplePkgName+  | QualSetup ExamplePkgName++    -- The two package names are the build target and the package containing the+    -- setup script.+  | QualIndepSetup ExamplePkgName ExamplePkgName++    -- The two package names are the package depending on the exe and the+    -- package containing the exe.+  | QualExe ExamplePkgName ExamplePkgName++-- | Whether to enable tests in all packages in a test case.+newtype EnableAllTests = EnableAllTests Bool+  deriving BooleanFlag++-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',+-- given:+--+--      1. The name 'ExamplePkgName' of the available package,+--      2. The version 'ExamplePkgVersion' available+--      3. The list of dependency constraints ('ExampleDependency')+--         for this package's library component.  'ExampleDependency'+--         provides a number of pre-canned dependency types to look at.+--+exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]+     -> ExampleAvailable+exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) }++-- | Constructs an 'ExampleAvailable' package without a default library+-- component.+exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable+exAvNoLibrary n v = ExAv { exAvName = n+                         , exAvVersion = v+                         , exAvDeps = CD.empty+                         , exAvFlags = [] }++-- | Override the default settings (e.g., manual vs. automatic) for a subset of+-- a package's flags.+declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable+declareFlags flags ex = ex {+      exAvFlags = flags+    }++withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable+withSubLibrary ex lib = withSubLibraries ex [lib]++withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable+withSubLibraries ex libs =+  let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps)+                              | ExSubLib name deps <- libs]+  in ex { exAvDeps = exAvDeps ex <> subLibCDs }++withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable+withSetupDeps ex setupDeps = ex {+      exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps)+    }++withTest :: ExampleAvailable -> ExTest -> ExampleAvailable+withTest ex test = withTests ex [test]++withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable+withTests ex tests =+  let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps)+                            | ExTest name deps <- tests]+  in ex { exAvDeps = exAvDeps ex <> testCDs }++withExe :: ExampleAvailable -> ExExe -> ExampleAvailable+withExe ex exe = withExes ex [exe]++withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable+withExes ex exes =+  let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps)+                           | ExExe name deps <- exes]+  in ex { exAvDeps = exAvDeps ex <> exeCDs }++-- | An installed package in 'ExampleDb'; construct me with 'exInst'.+data ExampleInstalled = ExInst {+    exInstName         :: ExamplePkgName+  , exInstVersion      :: ExamplePkgVersion+  , exInstHash         :: ExamplePkgHash+  , exInstBuildAgainst :: [ExamplePkgHash]+  } deriving Show++-- | Constructs an example installed package given:+--+--      1. The name of the package 'ExamplePkgName', i.e., 'String'+--      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'+--      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'+--         (just some unique identifier for the package.)+--      4. The 'ExampleInstalled' packages which this package was+--         compiled against.)+--+exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash+       -> [ExampleInstalled] -> ExampleInstalled+exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)++-- | An example package database is a list of installed packages+-- 'ExampleInstalled' and available packages 'ExampleAvailable'.+-- Generally, you want to use 'exInst' and 'exAv' to construct+-- these packages.+type ExampleDb = [Either ExampleInstalled ExampleAvailable]++type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a++type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a++exDbPkgs :: ExampleDb -> [ExamplePkgName]+exDbPkgs = map (either exInstName exAvName)++exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage+exAvSrcPkg ex =+    let pkgId = exAvPkgId ex++        flags :: [C.PackageFlag]+        flags =+          let declaredFlags :: Map ExampleFlagName C.PackageFlag+              declaredFlags =+                  Map.fromListWith+                      (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2])+                      [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex]++              usedFlags :: Map ExampleFlagName C.PackageFlag+              usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]+                where+                  names = extractFlags $ CD.flatDeps (exAvDeps ex)+          in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:+             Map.elems $ declaredFlags `Map.union` usedFlags++        subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)]+        foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)]+        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]+        benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)]+        executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]+        setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of+                  []   -> Nothing+                  deps -> Just C.SetupBuildInfo {+                            C.setupDepends = mkSetupDeps deps,+                            C.defaultSetupDepends = False+                          }+        package = SourcePackage+          { srcpkgPackageId     = pkgId+          , srcpkgSource        = LocalTarballPackage "<<path>>"+          , srcpkgDescrOverride = Nothing+          , srcpkgDescription   = C.GenericPackageDescription {+                C.packageDescription = C.emptyPackageDescription {+                    C.package        = pkgId+                  , C.setupBuildInfo = setup+                  , C.licenseRaw = Right BSD3+                  , C.buildTypeRaw = if isNothing setup+                                     then Just C.Simple+                                     else Just C.Custom+                  , C.category = "category"+                  , C.maintainer = "maintainer"+                  , C.description = "description"+                  , C.synopsis = "synopsis"+                  , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"]+                    -- Version 2.0 is required for internal libraries.+                  , C.specVersion = C.CabalSpecV2_0+                  }+              , C.gpdScannedVersion = Nothing+              , C.genPackageFlags = flags+              , C.condLibrary =+                  let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi }+                      -- Avoid using the Monoid instance for [a] when getting+                      -- the library dependencies, to allow for the possibility+                      -- that the package doesn't have a library:+                      libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex))+                  in mkTopLevelCondTree defaultLib mkLib <$> libDeps+              , C.condSubLibraries =+                  let mkTree = mkTopLevelCondTree defaultSubLib mkLib+                      mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi }+                  in map (second mkTree) subLibraries+              , C.condForeignLibs =+                  let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib)+                      mkLib bi = mempty { C.foreignLibBuildInfo = bi }+                  in map (second mkTree) foreignLibraries+              , C.condExecutables =+                  let mkTree = mkTopLevelCondTree defaultExe (const mkExe)+                      mkExe bi = mempty { C.buildInfo = bi }+                  in map (second mkTree) executables+              , C.condTestSuites =+                  let mkTree = mkTopLevelCondTree defaultTest (const mkTest)+                      mkTest bi = mempty { C.testBuildInfo = bi }+                  in map (second mkTree) testSuites+              , C.condBenchmarks  =+                  let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench)+                      mkBench bi = mempty { C.benchmarkBuildInfo = bi }+                  in map (second mkTree) benchmarks+              }+            }+        pkgCheckErrors =+          -- We ignore these warnings because some unit tests test that the+          -- solver allows unknown extensions/languages when the compiler+          -- supports them.+          let ignore = ["Unknown extensions:", "Unknown languages:"]+          in [ err | err <- C.checkPackage (srcpkgDescription package) Nothing+             , not $ any (`isPrefixOf` C.explanation err) ignore ]+    in if null pkgCheckErrors+       then package+       else error $ "invalid GenericPackageDescription for package "+                 ++ display pkgId ++ ": " ++ show pkgCheckErrors+  where+    defaultTopLevelBuildInfo :: C.BuildInfo+    defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }++    defaultLib :: C.Library+    defaultLib = mempty {+        C.libBuildInfo = defaultTopLevelBuildInfo+      , C.exposedModules = [Module.fromString "Module"]+      , C.libVisibility = C.LibraryVisibilityPublic+      }++    defaultSubLib :: C.Library+    defaultSubLib = mempty {+        C.libBuildInfo = defaultTopLevelBuildInfo+      , C.exposedModules = [Module.fromString "Module"]+      }++    defaultExe :: C.Executable+    defaultExe = mempty {+        C.buildInfo = defaultTopLevelBuildInfo+      , C.modulePath = "Main.hs"+      }++    defaultTest :: C.TestSuite+    defaultTest = mempty {+        C.testBuildInfo = defaultTopLevelBuildInfo+      , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"+      }++    defaultBenchmark :: C.Benchmark+    defaultBenchmark = mempty {+        C.benchmarkBuildInfo = defaultTopLevelBuildInfo+      , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs"+      }++    -- Split the set of dependencies into the set of dependencies of the library,+    -- the dependencies of the test suites and extensions.+    splitTopLevel :: [ExampleDependency]+                  -> ( [ExampleDependency]+                     , [Extension]+                     , Maybe Language+                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config+                     , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools+                     , [(ExamplePkgName, C.VersionRange)] -- legacy build tools+                     )+    splitTopLevel [] =+        ([], [], Nothing, [], [], [])+    splitTopLevel (ExBuildToolAny p e:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes)+    splitTopLevel (ExBuildToolFix p e v:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes)+    splitTopLevel (ExLegacyBuildToolAny p:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes)+    splitTopLevel (ExLegacyBuildToolFix p v:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes)+    splitTopLevel (ExExt ext:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, ext:exts, lang, pcpkgs, exes, legacyExes)+    splitTopLevel (ExLang lang:deps) =+        case splitTopLevel deps of+            (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes)+            _ -> error "Only 1 Language dependency is supported"+    splitTopLevel (ExPkg pkg:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (other, exts, lang, pkg:pcpkgs, exes, legacyExes)+    splitTopLevel (dep:deps) =+      let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps+      in (dep:other, exts, lang, pcpkgs, exes, legacyExes)++    -- Extract the total set of flags used+    extractFlags :: Dependencies -> [ExampleFlagName]+    extractFlags deps = concatMap go (depsExampleDependencies deps)+      where+        go :: ExampleDependency -> [ExampleFlagName]+        go (ExAny _)                  = []+        go (ExFix _ _)                = []+        go (ExRange _ _ _)            = []+        go (ExSubLibAny _ _)          = []+        go (ExSubLibFix _ _ _)        = []+        go (ExBuildToolAny _ _)       = []+        go (ExBuildToolFix _ _ _)     = []+        go (ExLegacyBuildToolAny _)   = []+        go (ExLegacyBuildToolFix _ _) = []+        go (ExFlagged f a b)          = f : extractFlags a ++ extractFlags b+        go (ExExt _)                  = []+        go (ExLang _)                 = []+        go (ExPkg _)                  = []++    -- Convert 'Dependencies' into a tree of a specific component type, using+    -- the given top level component and function for creating a component at+    -- any level.+    mkTopLevelCondTree :: forall a. Semigroup a =>+                          a+                       -> (C.LibraryVisibility -> C.BuildInfo -> a)+                       -> Dependencies+                       -> DependencyTree a+    mkTopLevelCondTree defaultTopLevel mkComponent deps =+      let condNode = mkCondTree mkComponent deps+      in condNode { C.condTreeData = defaultTopLevel <> C.condTreeData condNode }++    -- Convert 'Dependencies' into a tree of a specific component type, using+    -- the given function to generate each component.+    mkCondTree :: (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a+    mkCondTree mkComponent deps =+      let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps)+          (directDeps, flaggedDeps) = splitDeps libraryDeps+          component = mkComponent (depsVisibility deps) bi+          bi = mempty {+                  C.otherExtensions = exts+                , C.defaultLanguage = mlang+                , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr+                                       | (p, e, vr) <- buildTools]+                , C.buildTools = [ C.LegacyExeDependency n vr+                                 | (n,vr) <- legacyBuildTools]+                , C.pkgconfigDepends = [ C.PkgconfigDependency n' v'+                                       | (n,v) <- pcpkgs+                                       , let n' = C.mkPkgconfigName n+                                       , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ]+                , C.buildable = depsIsBuildable deps+              }+      in C.CondNode {+             C.condTreeData        = component+           -- TODO: Arguably, build-tools dependencies should also+           -- effect constraints on conditional tree. But no way to+           -- distinguish between them+           , C.condTreeConstraints = map mkDirect directDeps+           , C.condTreeComponents  = map (mkFlagged mkComponent) flaggedDeps+           }++    mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency+    mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name)++    mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a)+              -> (ExampleFlagName, Dependencies, Dependencies)+              -> DependencyComponent a+    mkFlagged mkComponent (f, a, b) =+        C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f)))+                     (mkCondTree mkComponent a)+                     (Just (mkCondTree mkComponent b))++    -- Split a set of dependencies into direct dependencies and flagged+    -- dependencies. A direct dependency is a tuple of the name of package and+    -- its version range meant to be converted to a 'C.Dependency' with+    -- 'mkDirect' for example. A flagged dependency is the set of dependencies+    -- guarded by a flag.+    splitDeps :: [ExampleDependency]+              -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)]+                 , [(ExampleFlagName, Dependencies, Dependencies)]+                 )+    splitDeps [] =+      ([], [])+    splitDeps (ExAny p:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps)+    splitDeps (ExFix p v:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps)+    splitDeps (ExRange p v1 v2:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps)+    splitDeps (ExSubLibAny p lib:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps)+    splitDeps (ExSubLibFix p lib v:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps)+    splitDeps (ExFlagged f a b:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in (directDeps, (f, a, b):flaggedDeps)+    splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep++    -- custom-setup only supports simple dependencies+    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]+    mkSetupDeps deps =+      case splitDeps deps of+        (directDeps, []) -> map mkDirect directDeps+        _                -> error "mkSetupDeps: custom setup has non-simple deps"++mkSimpleVersion :: ExamplePkgVersion -> C.Version+mkSimpleVersion n = C.mkVersion [n, 0, 0]++mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion+mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion++mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange+mkVersionRange v1 v2 =+    C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1)+                             (C.earlierVersion $ mkSimpleVersion v2)++mkFlag :: ExFlag -> C.PackageFlag+mkFlag flag = C.MkPackageFlag {+    C.flagName        = C.mkFlagName $ exFlagName flag+  , C.flagDescription = ""+  , C.flagDefault     = exFlagDefault flag+  , C.flagManual      =+      case exFlagType flag of+        Manual    -> True+        Automatic -> False+  }++mkDefaultFlag :: ExampleFlagName -> C.PackageFlag+mkDefaultFlag flag = C.MkPackageFlag {+    C.flagName        = C.mkFlagName flag+  , C.flagDescription = ""+  , C.flagDefault     = True+  , C.flagManual      = False+  }++exAvPkgId :: ExampleAvailable -> C.PackageIdentifier+exAvPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exAvName ex)+    , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]+    }++exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo+exInstInfo ex = IPI.emptyInstalledPackageInfo {+      IPI.installedUnitId    = C.mkUnitId (exInstHash ex)+    , IPI.sourcePackageId    = exInstPkgId ex+    , IPI.depends            = map C.mkUnitId (exInstBuildAgainst ex)+    }++exInstPkgId :: ExampleInstalled -> C.PackageIdentifier+exInstPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exInstName ex)+    , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]+    }++exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage+exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg++exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex+exInstIdx = C.PackageIndex.fromList . map exInstInfo++exResolve :: ExampleDb+          -- List of extensions supported by the compiler, or Nothing if unknown.+          -> Maybe [Extension]+          -- List of languages supported by the compiler, or Nothing if unknown.+          -> Maybe [Language]+          -> PC.PkgConfigDb+          -> [ExamplePkgName]+          -> Maybe Int+          -> CountConflicts+          -> FineGrainedConflicts+          -> MinimizeConflictSet+          -> IndependentGoals+          -> ReorderGoals+          -> AllowBootLibInstalls+          -> OnlyConstrained+          -> EnableBackjumping+          -> SolveExecutables+          -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)+          -> [ExConstraint]+          -> [ExPreference]+          -> C.Verbosity+          -> EnableAllTests+          -> Progress String String CI.SolverInstallPlan.SolverInstallPlan+exResolve db exts langs pkgConfigDb targets mbj countConflicts+          fineGrainedConflicts minimizeConflictSet indepGoals reorder+          allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder+          constraints prefs verbosity enableAllTests+    = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params+  where+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag+    compiler = defaultCompiler { C.compilerInfoExtensions = exts+                               , C.compilerInfoLanguages  = langs+                               }+    (inst, avai) = partitionEithers db+    instIdx      = exInstIdx inst+    avaiIdx      = SourcePackageDb {+                       packageIndex       = exAvIdx avai+                     , packagePreferences = Map.empty+                     }+    enableTests+        | asBool enableAllTests = fmap (\p -> PackageConstraint+                                              (scopeToplevel (C.mkPackageName p))+                                              (PackagePropertyStanzas [TestStanzas]))+                                       (exDbPkgs db)+        | otherwise             = []+    targets'     = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets+    params       =   addConstraints (fmap toConstraint constraints)+                   $ addConstraints (fmap toLpc enableTests)+                   $ addPreferences (fmap toPref prefs)+                   $ setCountConflicts countConflicts+                   $ setFineGrainedConflicts fineGrainedConflicts+                   $ setMinimizeConflictSet minimizeConflictSet+                   $ setIndependentGoals indepGoals+                   $ setReorderGoals reorder+                   $ setMaxBackjumps mbj+                   $ setAllowBootLibInstalls allowBootLibInstalls+                   $ setOnlyConstrained onlyConstrained+                   $ setEnableBackjumping enableBj+                   $ setSolveExecutables solveExes+                   $ setGoalOrder goalOrder+                   $ setSolverVerbosity verbosity+                   $ standardInstallPolicy instIdx avaiIdx targets'+    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown++    toConstraint (ExVersionConstraint scope v) =+        toLpc $ PackageConstraint scope (PackagePropertyVersion v)+    toConstraint (ExFlagConstraint scope fn b) =+        toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)]))+    toConstraint (ExStanzaConstraint scope stanzas) =+        toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas)++    toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v+    toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas++extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan+                   -> [(ExamplePkgName, ExamplePkgVersion)]+extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList+  where+    confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)+    confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg+    confPkg _                               = Nothing++    srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int)+    srcPkg cpkg =+      let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg)+      in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver)++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Run Progress computation+runProgress :: Progress step e a -> ([step], Either e a)+runProgress = go+  where+    go (Step s p) = let (ss, result) = go p in (s:ss, result)+    go (Fail e)   = ([], Left e)+    go (Done a)   = ([], Right a)
+ tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE RecordWildCards #-}+-- | Utilities for creating HUnit test cases with the solver DSL.+module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (+    SolverTest+  , SolverResult(..)+  , maxBackjumps+  , disableFineGrainedConflicts+  , minimizeConflictSet+  , independentGoals+  , allowBootLibInstalls+  , onlyConstrained+  , disableBackjumping+  , disableSolveExecutables+  , goalOrder+  , constraints+  , preferences+  , setVerbose+  , enableAllTests+  , solverSuccess+  , solverFailure+  , anySolverFailure+  , mkTest+  , mkTestExts+  , mkTestLangs+  , mkTestPCDepends+  , mkTestExtLangPC+  , runTest+  ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude++import Data.List (elemIndex)++-- test-framework+import Test.Tasty as TF+import Test.Tasty.HUnit (testCase, assertEqual, assertBool)++-- Cabal+import qualified Distribution.PackageDescription as C+import Language.Haskell.Extension (Extension(..), Language(..))+import Distribution.Verbosity++-- cabal-install+import qualified Distribution.Solver.Types.PackagePath as P+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)+import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.Variable+import Distribution.Client.Dependency (foldProgress)+import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Options++maxBackjumps :: Maybe Int -> SolverTest -> SolverTest+maxBackjumps mbj test = test { testMaxBackjumps = mbj }++disableFineGrainedConflicts :: SolverTest -> SolverTest+disableFineGrainedConflicts test =+    test { testFineGrainedConflicts = FineGrainedConflicts False }++minimizeConflictSet :: SolverTest -> SolverTest+minimizeConflictSet test =+    test { testMinimizeConflictSet = MinimizeConflictSet True }++-- | Combinator to turn on --independent-goals behavior, i.e. solve+-- for the goals as if we were solving for each goal independently.+independentGoals :: SolverTest -> SolverTest+independentGoals test = test { testIndepGoals = IndependentGoals True }++allowBootLibInstalls :: SolverTest -> SolverTest+allowBootLibInstalls test =+    test { testAllowBootLibInstalls = AllowBootLibInstalls True }++onlyConstrained :: SolverTest -> SolverTest+onlyConstrained test =+    test { testOnlyConstrained = OnlyConstrainedAll }++disableBackjumping :: SolverTest -> SolverTest+disableBackjumping test =+    test { testEnableBackjumping = EnableBackjumping False }++disableSolveExecutables :: SolverTest -> SolverTest+disableSolveExecutables test =+    test { testSolveExecutables = SolveExecutables False }++goalOrder :: [ExampleVar] -> SolverTest -> SolverTest+goalOrder order test = test { testGoalOrder = Just order }++constraints :: [ExConstraint] -> SolverTest -> SolverTest+constraints cs test = test { testConstraints = cs }++preferences :: [ExPreference] -> SolverTest -> SolverTest+preferences prefs test = test { testSoftConstraints = prefs }++-- | Increase the solver's verbosity. This is necessary for test cases that+-- check the contents of the verbose log.+setVerbose :: SolverTest -> SolverTest+setVerbose test = test { testVerbosity = verbose }++enableAllTests :: SolverTest -> SolverTest+enableAllTests test = test { testEnableAllTests = EnableAllTests True }++{-------------------------------------------------------------------------------+  Solver tests+-------------------------------------------------------------------------------}++data SolverTest = SolverTest {+    testLabel                :: String+  , testTargets              :: [String]+  , testResult               :: SolverResult+  , testMaxBackjumps         :: Maybe Int+  , testFineGrainedConflicts :: FineGrainedConflicts+  , testMinimizeConflictSet  :: MinimizeConflictSet+  , testIndepGoals           :: IndependentGoals+  , testAllowBootLibInstalls :: AllowBootLibInstalls+  , testOnlyConstrained      :: OnlyConstrained+  , testEnableBackjumping    :: EnableBackjumping+  , testSolveExecutables     :: SolveExecutables+  , testGoalOrder            :: Maybe [ExampleVar]+  , testConstraints          :: [ExConstraint]+  , testSoftConstraints      :: [ExPreference]+  , testVerbosity            :: Verbosity+  , testDb                   :: ExampleDb+  , testSupportedExts        :: Maybe [Extension]+  , testSupportedLangs       :: Maybe [Language]+  , testPkgConfigDb          :: PkgConfigDb+  , testEnableAllTests       :: EnableAllTests+  }++-- | Expected result of a solver test.+data SolverResult = SolverResult {+    -- | The solver's log should satisfy this predicate. Note that we also print+    -- the log, so evaluating a large log here can cause a space leak.+    resultLogPredicate            :: [String] -> Bool,++    -- | Fails with an error message satisfying the predicate, or succeeds with+    -- the given plan.+    resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]+  }++solverSuccess :: [(String, Int)] -> SolverResult+solverSuccess = SolverResult (const True) . Right++solverFailure :: (String -> Bool) -> SolverResult+solverFailure = SolverResult (const True) . Left++-- | Can be used for test cases where we just want to verify that+-- they fail, but do not care about the error message.+anySolverFailure :: SolverResult+anySolverFailure = solverFailure (const True)++-- | Makes a solver test case, consisting of the following components:+--+--      1. An 'ExampleDb', representing the package database (both+--         installed and remote) we are doing dependency solving over,+--      2. A 'String' name for the test,+--      3. A list '[String]' of package names to solve for+--      4. The expected result, either 'Nothing' if there is no+--         satisfying solution, or a list '[(String, Int)]' of+--         packages to install, at which versions.+--+-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how+-- to construct an 'ExampleDb', as well as definitions of 'db1' etc.+-- in this file.+mkTest :: ExampleDb+       -> String+       -> [String]+       -> SolverResult+       -> SolverTest+mkTest = mkTestExtLangPC Nothing Nothing (Just [])++mkTestExts :: [Extension]+           -> ExampleDb+           -> String+           -> [String]+           -> SolverResult+           -> SolverTest+mkTestExts exts = mkTestExtLangPC (Just exts) Nothing (Just [])++mkTestLangs :: [Language]+            -> ExampleDb+            -> String+            -> [String]+            -> SolverResult+            -> SolverTest+mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) (Just [])++mkTestPCDepends :: Maybe [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestPCDepends mPkgConfigDb = mkTestExtLangPC Nothing Nothing mPkgConfigDb++mkTestExtLangPC :: Maybe [Extension]+                -> Maybe [Language]+                -> Maybe [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestExtLangPC exts langs mPkgConfigDb db label targets result = SolverTest {+    testLabel                = label+  , testTargets              = targets+  , testResult               = result+  , testMaxBackjumps         = Nothing+  , testFineGrainedConflicts = FineGrainedConflicts True+  , testMinimizeConflictSet  = MinimizeConflictSet False+  , testIndepGoals           = IndependentGoals False+  , testAllowBootLibInstalls = AllowBootLibInstalls False+  , testOnlyConstrained      = OnlyConstrainedNone+  , testEnableBackjumping    = EnableBackjumping True+  , testSolveExecutables     = SolveExecutables True+  , testGoalOrder            = Nothing+  , testConstraints          = []+  , testSoftConstraints      = []+  , testVerbosity            = normal+  , testDb                   = db+  , testSupportedExts        = exts+  , testSupportedLangs       = langs+  , testPkgConfigDb          = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb+  , testEnableAllTests       = EnableAllTests False+  }++runTest :: SolverTest -> TF.TestTree+runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->+    testCase testLabel $ do+      let progress = exResolve testDb testSupportedExts+                     testSupportedLangs testPkgConfigDb testTargets+                     testMaxBackjumps (CountConflicts True)+                     testFineGrainedConflicts testMinimizeConflictSet+                     testIndepGoals (ReorderGoals False) testAllowBootLibInstalls+                     testOnlyConstrained testEnableBackjumping testSolveExecutables+                     (sortGoals <$> testGoalOrder) testConstraints+                     testSoftConstraints testVerbosity testEnableAllTests+          printMsg msg = when showSolverLog $ putStrLn msg+          msgs = foldProgress (:) (const []) (const []) progress+      assertBool ("Unexpected solver log:\n" ++ unlines msgs) $+                 resultLogPredicate testResult $ concatMap lines msgs+      result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress+      case result of+        Left  err  -> assertBool ("Unexpected error:\n" ++ err)+                                 (checkErrorMsg testResult err)+        Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))+  where+    toMaybe :: SolverResult -> Maybe [(String, Int)]+    toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan++    checkErrorMsg :: SolverResult -> String -> Bool+    checkErrorMsg result msg =+        case resultErrorMsgPredicateOrPlan result of+          Left f  -> f msg+          Right _ -> False++    sortGoals :: [ExampleVar]+              -> Variable P.QPN -> Variable P.QPN -> Ordering+    sortGoals = orderFromList . map toVariable++    -- Sort elements in the list ahead of elements not in the list. Otherwise,+    -- follow the order in the list.+    orderFromList :: Eq a => [a] -> a -> a -> Ordering+    orderFromList xs =+        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)++    toVariable :: ExampleVar -> Variable P.QPN+    toVariable (P q pn)        = PackageVar (toQPN q pn)+    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.mkFlagName fn)+    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza++    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN+    toQPN q pn = P.Q pp (C.mkPackageName pn)+      where+        pp = case q of+               QualNone           -> P.PackagePath P.DefaultNamespace P.QualToplevel+               QualIndep p        -> P.PackagePath (P.Independent $ C.mkPackageName p)+                                                   P.QualToplevel+               QualSetup s        -> P.PackagePath P.DefaultNamespace+                                                   (P.QualSetup (C.mkPackageName s))+               QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p)+                                                   (P.QualSetup (C.mkPackageName s))+               QualExe p1 p2      -> P.PackagePath P.DefaultNamespace+                                                   (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
+ tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs view
@@ -0,0 +1,196 @@+-- | Tests for detecting space leaks in the dependency solver.+module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where++import Test.Tasty (TestTree)++import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils++tests :: [TestTree]+tests = [+      runTest $ basicTest "basic space leak test"+    , runTest $ flagsTest "package with many flags"+    , runTest $ issue2899 "issue #2899"+    , runTest $ duplicateDependencies "duplicate dependencies"+    , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies"+    ]++-- | This test solves for n packages that each have two versions. There is no+-- solution, because the nth package depends on another package that doesn't fit+-- its version constraint. Backjumping and fine grained conflicts are disabled,+-- so the solver must explore a search tree of size 2^n. It should fail if+-- memory usage is proportional to the size of the tree.+basicTest :: String -> SolverTest+basicTest name =+    disableBackjumping $+    disableFineGrainedConflicts $+    mkTest pkgs name ["target"] anySolverFailure+  where+    n :: Int+    n = 18++    pkgs :: ExampleDb+    pkgs = map Right $+           [ exAv "target" 1 [ExAny $ pkgName 1]]+        ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4]+           | i <- [1..n], v <- [2, 3]]+        ++ [exAv (pkgName $ n + 1) 1 []]++    pkgName :: Int -> ExamplePkgName+    pkgName x = "pkg-" ++ show x++-- | This test is similar to 'basicTest', except that it has one package with n+-- flags, flag-1 through flag-n. The solver assigns flags in order, so it+-- doesn't discover the unknown dependencies under flag-n until it has assigned+-- all of the flags. It has to explore the whole search tree.+flagsTest :: String -> SolverTest+flagsTest name =+    disableBackjumping $+    disableFineGrainedConflicts $+    goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure+  where+    n :: Int+    n = 16++    pkgs :: ExampleDb+    pkgs = [Right $ exAv "pkg" 1 $+                [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]]++                -- The remaining flags have no effect:+             ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]]+           ]++    orderedFlags :: [ExampleVar]+    orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]]++-- | Test for a space leak caused by sharing of search trees under packages with+-- link choices (issue #2899).+--+-- The goal order is fixed so that the solver chooses setup-dep and then+-- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep+-- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep+-- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n+-- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each+-- dependency has two versions, the solver must try 2^n combinations when+-- backjumping and fine grained conflicts are disabled. These combinations+-- create large search trees under each of the two choices for+-- target-setup.setup-dep. Although the choice to not link is disallowed by the+-- Single Instance Restriction, the solver doesn't know that until it has+-- explored (and evaluated) the whole tree under the choice to link. If the two+-- trees are shared, memory usage spikes.+issue2899 :: String -> SolverTest+issue2899 name =+    disableBackjumping $+    disableFineGrainedConflicts $+    goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure+  where+    n :: Int+    n = 16++    pkgs :: ExampleDb+    pkgs = map Right $+           [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"]+           , exAv "setup-dep" 1 [ExAny $ pkgName 1]]+        ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)]+           | i <- [1..n], v <- [1, 2]]++    pkgName :: Int -> ExamplePkgName+    pkgName x = "pkg-" ++ show x++    goals :: [ExampleVar]+    goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"]++-- | Test for an issue related to lifting dependencies out of conditionals when+-- converting a PackageDescription to the solver's internal representation.+--+-- Issue:+-- For each conditional and each package B, the solver combined each dependency+-- on B in the true branch with each dependency on B in the false branch. It+-- added the combined dependencies to the build-depends outside of the+-- conditional. Since dependencies could be lifted out of multiple levels of+-- conditionals, the number of new dependencies could grow exponentially in the+-- number of levels. For example, the following package generated 4 copies of B+-- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top+-- level:+--+-- if flag(flag-1)+--   build-depends: B, B+-- else+--   if flag(flag-2)+--     build-depends: B, B+--   else+--     if flag(flag-3)+--       build-depends: B, B+--     else+--       build-depends: B, B+--+-- This issue caused the quickcheck tests to start frequently running out of+-- memory after an optimization that pruned unreachable branches (See PR #4929).+-- Each problematic test case contained at least one build-depends field with+-- duplicate dependencies, which was then duplicated under multiple levels of+-- conditionals by the solver's "buildable: False" transformation, when+-- "buildable: False" was under multiple flags. Finally, the branch pruning+-- feature put all build-depends fields in consecutive levels of the condition+-- tree, causing the solver's representation of the package to follow the+-- pattern in the example above.+--+-- Now the solver avoids this issue by combining all dependencies on the same+-- package before lifting them out of conditionals.+--+-- This test case is an expanded version of the example above, with library and+-- build-tool dependencies.+duplicateDependencies :: String -> SolverTest+duplicateDependencies name =+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    copies, depth :: Int+    copies = 50+    depth = 50++    pkgs :: ExampleDb+    pkgs = [+        Right $ exAv "A" 1 (dependencyTree 1)+      , Right $ exAv "B" 1 [] `withExe` exExe "exe" []+      ]++    dependencyTree :: Int -> [ExampleDependency]+    dependencyTree n+        | n > depth = buildDepends+        | otherwise = [exFlagged (numberedFlag n) buildDepends+                                                  (dependencyTree (n + 1))]+      where+        buildDepends = replicate copies (ExFix "B" 1)+                    ++ replicate copies (ExBuildToolFix "B" "exe" 1)++-- | This test is similar to duplicateDependencies, except that every dependency+-- on B is replaced by a conditional that contains B in both branches. It tests+-- that the solver doesn't just combine dependencies within one build-depends or+-- build-tool-depends field; it also needs to combine dependencies after they+-- are lifted out of conditionals.+duplicateFlaggedDependencies :: String -> SolverTest+duplicateFlaggedDependencies name =+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    copies, depth :: Int+    copies = 15+    depth = 15++    pkgs :: ExampleDb+    pkgs = [+        Right $ exAv "A" 1 (dependencyTree 1)+      , Right $ exAv "B" 1 [] `withExe` exExe "exe" []+      ]++    dependencyTree :: Int -> [ExampleDependency]+    dependencyTree n+        | n > depth = flaggedDeps+        | otherwise = [exFlagged (numberedFlag n) flaggedDeps+                                                  (dependencyTree (n + 1))]+      where+        flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..]+        flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends+                                                                   buildDepends+        buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1]++numberedFlag :: Int -> ExampleFlagName+numberedFlag n = "flag-" ++ show n
+ tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs view
@@ -0,0 +1,553 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Arrow ((&&&))+import Data.Either (lefts)+import Data.Hashable (Hashable(..))+import Data.List (groupBy, isInfixOf)++import Text.Show.Pretty (parseValue, valToStr)++import Test.Tasty (TestTree)+import Test.QuickCheck (Arbitrary (..), Gen, Positive (..), frequency, oneof, shrinkList, shuffle, listOf, shrinkNothing, vectorOf, elements, sublistOf, counterexample, (===), (==>), Blind (..))+import Test.QuickCheck.Instances.Cabal ()++import Distribution.Types.Flag (FlagName)+import Distribution.Utils.ShortText (ShortText)++import Distribution.Client.Setup (defaultMaxBackjumps)++import           Distribution.Types.LibraryVisibility+import           Distribution.Types.PackageName+import           Distribution.Types.UnqualComponentName++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps+                   ( Component(..), ComponentDep, ComponentDeps )+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackagePath as P+import           Distribution.Solver.Types.PkgConfigDb+                   (pkgConfigDbFromList)+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.Variable+import           Distribution.Verbosity+import           Distribution.Version++import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils+    ( testPropertyWithSeed )++tests :: [TestTree]+tests = [+      -- This test checks that certain solver parameters do not affect the+      -- existence of a solution. It runs the solver twice, and only sets those+      -- parameters on the second run. The test also applies parameters that+      -- can affect the existence of a solution to both runs.+      testPropertyWithSeed "target and goal order do not affect solvability" $+          \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals ->+            let r1 = solve' mGoalOrder1 test+                r2 = solve' mGoalOrder2 test { testTargets = targets2 }+                solve' goalOrder =+                    solve (EnableBackjumping True) (FineGrainedConflicts True)+                          (ReorderGoals False) (CountConflicts True) indepGoals+                          (getBlind <$> goalOrder)+                targets = testTargets test+                targets2 = case targetOrder of+                             SameOrder -> targets+                             ReverseOrder -> reverse targets+            in counterexample (showResults r1 r2) $+               noneReachedBackjumpLimit [r1, r2] ==>+               isRight (resultPlan r1) === isRight (resultPlan r2)++    , testPropertyWithSeed+          "solvable without --independent-goals => solvable with --independent-goals" $+          \test reorderGoals ->+            let r1 = solve' (IndependentGoals False) test+                r2 = solve' (IndependentGoals True)  test+                solve' indep =+                    solve (EnableBackjumping True) (FineGrainedConflicts True)+                          reorderGoals (CountConflicts True) indep Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) `implies` isRight (resultPlan r2)++    , testPropertyWithSeed "backjumping does not affect solvability" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  test+                r2 = solve' (EnableBackjumping False) test+                solve' enableBj =+                    solve enableBj (FineGrainedConflicts False) reorderGoals+                          (CountConflicts True) indepGoals Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) === isRight (resultPlan r2)++    , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (FineGrainedConflicts True)  test+                r2 = solve' (FineGrainedConflicts False) test+                solve' fineGrainedConflicts =+                    solve (EnableBackjumping True) fineGrainedConflicts+                    reorderGoals (CountConflicts True) indepGoals Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) === isRight (resultPlan r2)++    -- The next two tests use --no-count-conflicts, because the goal order used+    -- with --count-conflicts depends on the total set of conflicts seen by the+    -- solver. The solver explores more of the tree and encounters more+    -- conflicts when it doesn't backjump. The different goal orders can lead to+    -- different solutions and cause the test to fail.+    -- TODO: Find a faster way to randomly sort goals, and then use a random+    -- goal order in these tests.++    , testPropertyWithSeed+          "backjumping does not affect the result (with static goal order)" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  test+                r2 = solve' (EnableBackjumping False) test+                solve' enableBj =+                    solve enableBj (FineGrainedConflicts False) reorderGoals+                          (CountConflicts False) indepGoals Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                resultPlan r1 === resultPlan r2++    , testPropertyWithSeed+          "fine-grained conflicts does not affect the result (with static goal order)" $+          \test reorderGoals indepGoals ->+            let r1 = solve' (FineGrainedConflicts True)  test+                r2 = solve' (FineGrainedConflicts False) test+                solve' fineGrainedConflicts =+                    solve (EnableBackjumping True) fineGrainedConflicts+                          reorderGoals (CountConflicts False) indepGoals Nothing+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                resultPlan r1 === resultPlan r2+    ]+  where+    noneReachedBackjumpLimit :: [Result] -> Bool+    noneReachedBackjumpLimit =+        not . any (\r -> resultPlan r == Left BackjumpLimitReached)++    showResults :: Result -> Result -> String+    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2++    showResult :: Int -> Result -> String+    showResult n result =+        unlines $ ["", "Run " ++ show n ++ ":"]+               ++ resultLog result+               ++ ["result: " ++ show (resultPlan result)]++    implies :: Bool -> Bool -> Bool+    implies x y = not x || y++    isRight :: Either a b -> Bool+    isRight (Right _) = True+    isRight _         = False++newtype VarOrdering = VarOrdering {+      unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering+    }++solve :: EnableBackjumping+      -> FineGrainedConflicts+      -> ReorderGoals+      -> CountConflicts+      -> IndependentGoals+      -> Maybe VarOrdering+      -> SolverTest+      -> Result+solve enableBj fineGrainedConflicts reorder countConflicts indep goalOrder test =+  let (lg, result) =+        runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing+                  (pkgConfigDbFromList [])+                  (map unPN (testTargets test))+                  -- The backjump limit prevents individual tests from using+                  -- too much time and memory.+                  (Just defaultMaxBackjumps)+                  countConflicts fineGrainedConflicts+                  (MinimizeConflictSet False) indep reorder+                  (AllowBootLibInstalls False) OnlyConstrainedNone enableBj+                  (SolveExecutables True) (unVarOrdering <$> goalOrder)+                  (testConstraints test) (testPreferences test) normal+                  (EnableAllTests False)++      failure :: String -> Failure+      failure msg+        | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached+        | otherwise                                = OtherFailure+  in Result {+       resultLog = lg+     , resultPlan =+         -- Force the result so that we check for internal errors when we check+         -- for success or failure. See D.C.Dependency.validateSolverResult.+         force $ either (Left . failure) (Right . extractInstallPlan) result+     }++-- | How to modify the order of the input targets.+data TargetOrder = SameOrder | ReverseOrder+  deriving Show++instance Arbitrary TargetOrder where+  arbitrary = elements [SameOrder, ReverseOrder]++  shrink SameOrder = []+  shrink ReverseOrder = [SameOrder]++data Result = Result {+    resultLog :: [String]+  , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)]+  }++data Failure = BackjumpLimitReached | OtherFailure+  deriving (Eq, Generic, Show)++instance NFData Failure++-- | Package name.+newtype PN = PN { unPN :: String }+  deriving (Eq, Ord, Show)++instance Arbitrary PN where+  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])++-- | Package version.+newtype PV = PV { unPV :: Int }+  deriving (Eq, Ord, Show)++instance Arbitrary PV where+  arbitrary = PV <$> elements [1..10]++type TestPackage = Either ExampleInstalled ExampleAvailable++getName :: TestPackage -> PN+getName = PN . either exInstName exAvName++getVersion :: TestPackage -> PV+getVersion = PV . either exInstVersion exAvVersion++data SolverTest = SolverTest {+    testDb :: TestDb+  , testTargets :: [PN]+  , testConstraints :: [ExConstraint]+  , testPreferences :: [ExPreference]+  }++-- | Pretty-print the test when quickcheck calls 'show'.+instance Show SolverTest where+  show test =+    let str = "SolverTest {testDb = " ++ show (testDb test)+                     ++ ", testTargets = " ++ show (testTargets test)+                     ++ ", testConstraints = " ++ show (testConstraints test)+                     ++ ", testPreferences = " ++ show (testPreferences test)+                     ++ "}"+    in maybe str valToStr $ parseValue str++instance Arbitrary SolverTest where+  arbitrary = do+    db <- arbitrary+    let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db)+        pkgs = nub $ map fst pkgVersions+    Positive n <- arbitrary+    targets <- randomSubset n pkgs+    constraints <- case pkgVersions of+                     [] -> return []+                     _  -> boundedListOf 1 $ arbitraryConstraint pkgVersions+    prefs <- case pkgVersions of+               [] -> return []+               _  -> boundedListOf 3 $ arbitraryPreference pkgVersions+    return (SolverTest db targets constraints prefs)++  shrink test =+         [test { testDb = db } | db <- shrink (testDb test)]+      ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]+      ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)]+      ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)]++-- | Collection of source and installed packages.+newtype TestDb = TestDb { unTestDb :: ExampleDb }+  deriving Show++instance Arbitrary TestDb where+  arbitrary = do+      -- Avoid cyclic dependencies by grouping packages by name and only+      -- allowing each package to depend on packages in the groups before it.+      groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<+                     boundedListOf 10 arbitrary+      db <- foldM nextPkgs (TestDb []) groupedPkgs+      TestDb <$> shuffle (unTestDb db)+    where+      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb+      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs++      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage+      nextPkg db (pn, v) = do+        installed <- arbitrary+        if installed+        then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)+        else Right <$> arbitraryExAv pn v db++  shrink (TestDb pkgs) = map TestDb $ shrink pkgs++arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable+arbitraryExAv pn v db =+    (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db++arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled+arbitraryExInst pn v pkgs = do+  pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']+  numDeps <- min 3 <$> arbitrary+  deps <- randomSubset numDeps pkgs+  return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps)++arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps Dependencies)+arbitraryComponentDeps _  (TestDb []) = return $ CD.fromLibraryDeps (dependencies [])+arbitraryComponentDeps pn db          = do+  -- dedupComponentNames removes components with duplicate names, for example,+  -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines+  -- duplicate unnamed components.+  cds <- CD.fromList . dedupComponentNames . filter (isValid . fst)+           <$> boundedListOf 5 (arbitraryComponentDep db)+  return $ if isCompleteComponentDeps cds+           then cds+           else -- Add a library if the ComponentDeps isn't complete.+                CD.fromLibraryDeps (dependencies []) <> cds+  where+    isValid :: Component -> Bool+    isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn)+    isValid _                      = True++    dedupComponentNames =+        nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)++    componentName :: Component -> Maybe UnqualComponentName+    componentName ComponentLib        = Nothing+    componentName ComponentSetup      = Nothing+    componentName (ComponentSubLib n) = Just n+    componentName (ComponentFLib   n) = Just n+    componentName (ComponentExe    n) = Just n+    componentName (ComponentTest   n) = Just n+    componentName (ComponentBench  n) = Just n++-- | Returns true if the ComponentDeps forms a complete package, i.e., it+-- contains a library, exe, test, or benchmark.+isCompleteComponentDeps :: ComponentDeps a -> Bool+isCompleteComponentDeps = any (completesPkg . fst) . CD.toList+  where+    completesPkg ComponentLib        = True+    completesPkg (ComponentExe    _) = True+    completesPkg (ComponentTest   _) = True+    completesPkg (ComponentBench  _) = True+    completesPkg (ComponentSubLib _) = False+    completesPkg (ComponentFLib   _) = False+    completesPkg ComponentSetup      = False++arbitraryComponentDep :: TestDb -> Gen (ComponentDep Dependencies)+arbitraryComponentDep db = do+  comp <- arbitrary+  deps <- case comp of+            ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)+            _              -> boundedListOf 5 (arbitraryExDep db NonSetupDep)+  return ( comp+         , Dependencies {+             depsExampleDependencies = deps++           -- TODO: Test different values for visibility and buildability.+           , depsVisibility = LibraryVisibilityPublic+           , depsIsBuildable = True+           } )++-- | Location of an 'ExampleDependency'. It determines which values are valid.+data ExDepLocation = SetupDep | NonSetupDep++arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency+arbitraryExDep db@(TestDb pkgs) level =+  let flag = ExFlagged <$> arbitraryFlagName+                       <*> arbitraryDeps db+                       <*> arbitraryDeps db+      other =+          -- Package checks require dependencies on "base" to have bounds.+        let notBase = filter ((/= PN "base") . getName) pkgs+        in  [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]+         ++ [+              -- existing version+              let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)+              in fixed <$> elements pkgs++              -- random version of an existing package+            , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)+            ]+  in oneof $+      case level of+        NonSetupDep -> flag : other+        SetupDep -> other++arbitraryDeps :: TestDb -> Gen Dependencies+arbitraryDeps db = frequency+    [ (1, return unbuildableDependencies)+    , (20, dependencies <$> smallListOf (arbitraryExDep db NonSetupDep))+    ]++arbitraryFlagName :: Gen String+arbitraryFlagName = (:[]) <$> elements ['A'..'E']++arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint+arbitraryConstraint pkgs = do+  (PN pn, v) <- elements pkgs+  let anyQualifier = ScopeAnyQualifier (mkPackageName pn)+  oneof [+      ExVersionConstraint anyQualifier <$> arbitraryVersionRange v+    , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas]+    ]++arbitraryPreference :: [(PN, PV)] -> Gen ExPreference+arbitraryPreference pkgs = do+  (PN pn, v) <- elements pkgs+  oneof [+      ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas]+    , ExPkgPref pn <$> arbitraryVersionRange v+    ]++arbitraryVersionRange :: PV -> Gen VersionRange+arbitraryVersionRange (PV v) =+  let version = mkSimpleVersion v+  in elements [+         thisVersion version+       , notThisVersion version+       , earlierVersion version+       , orLaterVersion version+       , noVersion+       ]++instance Arbitrary ReorderGoals where+  arbitrary = ReorderGoals <$> arbitrary++  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]++instance Arbitrary IndependentGoals where+  arbitrary = IndependentGoals <$> arbitrary++  shrink (IndependentGoals indep) = [IndependentGoals False | indep]++instance Arbitrary Component where+  arbitrary = oneof [ return ComponentLib+                    , ComponentSubLib <$> arbitraryUQN+                    , ComponentExe <$> arbitraryUQN+                    , ComponentFLib <$> arbitraryUQN+                    , ComponentTest <$> arbitraryUQN+                    , ComponentBench <$> arbitraryUQN+                    , return ComponentSetup+                    ]++  shrink ComponentLib = []+  shrink _ = [ComponentLib]++-- The "component-" prefix prevents component names and build-depends+-- dependency names from overlapping.+-- TODO: Remove the prefix once the QuickCheck tests support dependencies on+-- internal libraries.+arbitraryUQN :: Gen UnqualComponentName+arbitraryUQN =+    mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"++instance Arbitrary ExampleInstalled where+  arbitrary = error "arbitrary not implemented: ExampleInstalled"++  shrink ei = [ ei { exInstBuildAgainst = deps }+              | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]++instance Arbitrary ExampleAvailable where+  arbitrary = error "arbitrary not implemented: ExampleAvailable"++  shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]++instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where+  arbitrary = error "arbitrary not implemented: ComponentDeps"++  shrink = filter isCompleteComponentDeps . map CD.fromList . shrink . CD.toList++instance Arbitrary ExampleDependency where+  arbitrary = error "arbitrary not implemented: ExampleDependency"++  shrink (ExAny _) = []+  shrink (ExFix "base" _) = [] -- preserve bounds on base+  shrink (ExFix pn _) = [ExAny pn]+  shrink (ExFlagged flag th el) =+         depsExampleDependencies th ++ depsExampleDependencies el+      ++ [ExFlagged flag th' el | th' <- shrink th]+      ++ [ExFlagged flag th el' | el' <- shrink el]+  shrink dep = error $ "Dependency not handled: " ++ show dep++instance Arbitrary Dependencies where+  arbitrary = error "arbitrary not implemented: Dependencies"++  shrink deps =+         [ deps { depsVisibility = v } | v <- shrink $ depsVisibility deps ]+      ++ [ deps { depsIsBuildable = b } | b <- shrink $ depsIsBuildable deps ]+      ++ [ deps { depsExampleDependencies = ds } | ds <- shrink $ depsExampleDependencies deps ]++instance Arbitrary ExConstraint where+  arbitrary = error "arbitrary not implemented: ExConstraint"++  shrink (ExStanzaConstraint scope stanzas) =+      [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas]+  shrink (ExVersionConstraint scope vr) =+      [ExVersionConstraint scope vr' | vr' <- shrink vr]+  shrink _ = []++instance Arbitrary ExPreference where+  arbitrary = error "arbitrary not implemented: ExPreference"++  shrink (ExStanzaPref pn stanzas) =+      [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas]+  shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr]++instance Arbitrary OptionalStanza where+  arbitrary = error "arbitrary not implemented: OptionalStanza"++  shrink BenchStanzas = [TestStanzas]+  shrink TestStanzas  = []++-- Randomly sorts solver variables using 'hash'.+-- TODO: Sorting goals with this function is very slow.+instance Arbitrary VarOrdering where+  arbitrary = do+      f <- arbitrary :: Gen (Int -> Int)+      return $ VarOrdering (comparing (f . hash))++instance Hashable pn => Hashable (Variable pn)+instance Hashable a => Hashable (P.Qualified a)+instance Hashable P.PackagePath+instance Hashable P.Qualifier+instance Hashable P.Namespace+instance Hashable OptionalStanza+instance Hashable FlagName+instance Hashable PackageName+instance Hashable ShortText++deriving instance Generic (Variable pn)+deriving instance Generic (P.Qualified a)+deriving instance Generic P.PackagePath+deriving instance Generic P.Namespace+deriving instance Generic P.Qualifier++randomSubset :: Int -> [a] -> Gen [a]+randomSubset n xs = take n <$> shuffle xs++boundedListOf :: Int -> Gen a -> Gen [a]+boundedListOf n gen = take n <$> listOf gen++-- | Generates lists with average length less than 1.+smallListOf :: Gen a -> Gen [a]+smallListOf gen =+    frequency [ (fr, vectorOf n gen)+              | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
+ tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs view
@@ -0,0 +1,33 @@+module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils (+    testPropertyWithSeed+  ) where++import Data.Tagged (Tagged, retag)+import System.Random (getStdRandom, random)++import Test.Tasty (TestTree)+import Test.Tasty.Options (OptionDescription, lookupOption, setOption)+import Test.Tasty.Providers (IsTest (..), singleTest)+import Test.Tasty.QuickCheck+    ( QC (..), QuickCheckReplay (..), Testable, property )++import Distribution.Simple.Utils+import Distribution.Verbosity++-- | Create a QuickCheck test that prints the seed before testing the property.+-- The seed can be useful for debugging non-terminating test cases. This is+-- related to https://github.com/feuerbach/tasty/issues/86.+testPropertyWithSeed :: Testable a => String -> a -> TestTree+testPropertyWithSeed name = singleTest name . QCWithSeed . QC . property++newtype QCWithSeed = QCWithSeed QC++instance IsTest QCWithSeed where+  testOptions = retag (testOptions :: Tagged QC [OptionDescription])++  run options (QCWithSeed test) progress = do+    replay <- case lookupOption options of+                 QuickCheckReplay (Just override) -> return override+                 QuickCheckReplay Nothing         -> getStdRandom random+    notice normal $ "Using --quickcheck-replay=" ++ show replay+    run (setOption (QuickCheckReplay (Just replay)) options) test progress
+ tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module UnitTests.Distribution.Solver.Modular.RetryLog (+  tests+  ) where++import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Types.Progress++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck+         ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===))++type Log a = Progress a String String++tests :: [TestTree]+tests = [+    testProperty "'toProgress . fromProgress' is identity" $ \p ->+        toProgress (fromProgress p) === (p :: Log Int)++  , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $+        let mapFailureProgress f = foldProgress Step (Fail . f) Done+        in \(Blind f) p ->+               toProgress (mapFailure f (fromProgress p))+               === mapFailureProgress (f :: String -> Int) (p :: Log Int)++  , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $+      \p (Blind f) ->+        toProgress (retry (fromProgress p) (fromProgress . f))+        === (foldProgress Step f Done (p :: Log Int) :: Log Int)++  , testProperty "failWith" $ \step failure ->+        toProgress (failWith step failure)+        === (Step step (Fail failure) :: Log Int)++  , testProperty "succeedWith" $ \step success ->+        toProgress (succeedWith step success)+        === (Step step (Done success) :: Log Int)++  , testProperty "continueWith" $ \step p ->+        toProgress (continueWith step (fromProgress p))+        === (Step step p :: Log Int)++  , testCase "tryWith with failure" $+        let failure = Fail "Error"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s failure)))+           @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)++  , testCase "tryWith with success" $+        let done = Done "Done"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s done)))+           @?= (s (Step Enter (s (s done))) :: Log Message)+  ]++instance (Arbitrary step, Arbitrary fail, Arbitrary done)+    => Arbitrary (Progress step fail done) where+  arbitrary = do+    steps <- listOf arbitrary+    end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary]+    return $ foldr Step end steps++deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)++deriving instance (Show step, Show fail, Show done)+    => Show (Progress step fail done)++deriving instance Eq Message+deriving instance Show Message
+ tests/UnitTests/Distribution/Solver/Modular/Solver.hs view
@@ -0,0 +1,2117 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This is a set of unit tests for the dependency solver,+-- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL")+-- to more conveniently create package databases to run the solver tests on.+module UnitTests.Distribution.Solver.Modular.Solver (tests)+       where++-- base+import Data.List (isInfixOf)++import qualified Distribution.Version as V++-- test-framework+import Test.Tasty as TF++-- Cabal+import Language.Haskell.Extension ( Extension(..)+                                  , KnownExtension(..), Language(..))++-- cabal-install+import Distribution.Solver.Types.Flag+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackagePath as P+import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils++tests :: [TF.TestTree]+tests = [+      testGroup "Simple dependencies" [+          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (solverSuccess [])+        , runTest $         mkTest db1 "installLatest"      ["B"]      (solverSuccess [("B", 2)])+        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (solverSuccess [("B", 1), ("C", 1)])+        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (solverSuccess [("B", 2), ("D", 1)])+        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)])+        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (solverSuccess [("B", 1), ("E", 1), ("F", 1)])+        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (solverSuccess [("B", 2), ("E", 1), ("G", 1)])+        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] anySolverFailure+        , runTest $         mkTest db21 "unknownPackage1"   ["A"]      (solverSuccess [("A", 1), ("B", 1)])+        , runTest $         mkTest db22 "unknownPackage2"   ["A"]      (solverFailure (isInfixOf "unknown package: C"))+        , runTest $         mkTest db23 "unknownPackage3"   ["A"]      (solverFailure (isInfixOf "unknown package: B"))+        , runTest $         mkTest []   "unknown target"    ["A"]      (solverFailure (isInfixOf "unknown package: A"))+        ]+    , testGroup "Flagged dependencies" [+          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $         mkTest db3 "forceFlagOff" ["D"]      (solverSuccess [("A", 2), ("B", 1), ("D", 1)])+        , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])+        ]+    , testGroup "Lifting dependencies out of conditionals" [+          runTest $ commonDependencyLogMessage "common dependency log message"+        , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message"+        , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency"+        ]+    , testGroup "Manual flags" [+          runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $+          solverSuccess [("pkg", 1), ("true-dep", 1)]++        , let checkFullLog =+                  any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)"+          in runTest $ setVerbose $+             constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $+             mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $+             -- TODO: We should check the summarized log instead of the full log+             -- for the manual flags error message, but it currently only+             -- appears in the full log.+             SolverResult checkFullLog (Left $ const True)++        , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False]+          in runTest $ constraints cs $+             mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $+             solverSuccess [("false-dep", 1), ("pkg", 1)]+        ]+    , testGroup "Qualified manual flag constraints" [+          let name = "Top-level flag constraint does not constrain setup dep's flag"+              cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ]++        , let name = "Solver can toggle setup dep's flag to match top-level constraint"+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False+                   , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ]++        , let name = "User can constrain flags separately with qualified constraints"+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ]++          -- Regression test for #4299+        , let name = "Solver can link deps when only one has constrained manual flag"+              cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]+          in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ]++        , let name = "Solver cannot link deps that have conflicting manual flag constraints"+              cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]+              failureReason = "(constraint from unknown source requires opposite flag selection)"+              checkFullLog lns =+                  all (\msg -> any (msg `isInfixOf`) lns)+                  [ "rejecting: B:-flag "         ++ failureReason+                  , "rejecting: A:setup.B:+flag " ++ failureReason ]+          in runTest $ constraints cs $ setVerbose $+             mkTest dbLinkedSetupDepWithManualFlag name ["A"] $+             SolverResult checkFullLog (Left $ const True)+        ]+    , testGroup "Stanzas" [+          runTest $         enableAllTests $ mkTest db5 "simpleTest1" ["C"]      (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest2" ["D"]      anySolverFailure+        , runTest $         enableAllTests $ mkTest db5 "simpleTest3" ["E"]      (solverSuccess [("A", 1), ("E", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO+        , runTest $         enableAllTests $ mkTest db5 "simpleTest5" ["G"]      (solverSuccess [("A", 2), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure+        , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])+        , runTest $ testTestSuiteWithFlag "test suite with flag"+        ]+    , testGroup "Setup dependencies" [+          runTest $         mkTest db7  "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])+        , runTest $         mkTest db7  "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         mkTest db7  "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)])+        , runTest $         mkTest db7  "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)])+        , runTest $         mkTest db7  "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)])+        , runTest $         mkTest db8  "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db9  "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])+        , runTest $         mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])+        , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])+        ]+    , testGroup "Base shim" [+          runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)])+        , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure+        , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)])+        ]+    , testGroup "Base" [+          runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $+                      solverFailure (isInfixOf "only already installed instances can be used")+        , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $+                      solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]+        ]+    , testGroup "reject-unconstrained" [+          runTest $ onlyConstrained $ mkTest db12 "missing syb" ["E"] $+            solverFailure (isInfixOf "not a user-provided goal")+        , runTest $ onlyConstrained $ mkTest db12 "all goals" ["E", "syb"] $+            solverSuccess [("E", 1), ("syb", 2)]+        , runTest $ onlyConstrained $ mkTest db17 "backtracking" ["A", "B"] $+            solverSuccess [("A", 2), ("B", 1)]+        , runTest $ onlyConstrained $ mkTest db17 "failure message" ["A"] $+            solverFailure $ isInfixOf $+                  "Could not resolve dependencies:\n"+               ++ "[__0] trying: A-3.0.0 (user goal)\n"+               ++ "[__1] next goal: C (dependency of A)\n"+               ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, "+                      ++ "but reject-unconstrained-dependencies was set)\n"+               ++ "[__1] fail (backjumping, conflict set: A, C)\n"+               ++ "After searching the rest of the dependency tree exhaustively, "+                      ++ "these were the goals I've had most trouble fulfilling: A, C, B"+        ]+    , testGroup "Cycles" [+          runTest $ mkTest db14 "simpleCycle1"          ["A"]      anySolverFailure+        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] anySolverFailure+        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (solverSuccess [("C", 1), ("E", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (solverSuccess [("C", 2), ("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (solverSuccess [("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (solverSuccess [("C", 2), ("D", 1), ("E", 1)])+        , runTest $ issue4161 "detect cycle between package and its setup script"+        , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"+        ]+    , testGroup "Extensions" [+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)])+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)])+        ]+    , testGroup "Languages" [+          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)])+        ]+     , testGroup "Qualified Package Constraints" [+          runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $+          solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]++        , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ]+          in runTest $ constraints cs $+             mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $+             solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]++        , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel    "D") $ mkVersionRange 1 4+                   , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7+                   ]+          in runTest $ constraints cs $+             mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $+             solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]++        , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ]+          in runTest $ constraints cs $+             mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $+             solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)]+        ]+     , testGroup "Package Preferences" [+          runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2+                                , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])+        ]+     , testGroup "Stanza Preferences" [+          runTest $+          mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $+          solverSuccess [("pkg", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $+          solverSuccess [("pkg", 1), ("test-dep", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $+          solverSuccess [("pkg", 1)]++        , testStanzaPreference "test stanza preference"+        ]+     , testGroup "Buildable Field" [+          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")+        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))+        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))+        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])+        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])+         ]+    , testGroup "Pkg-config dependencies" [+          runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])+        , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D",1)])+        ]+    , testGroup "Independent goals" [+          runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])+        , runTest $ testIndepGoals2 "indepGoals2"+        , runTest $ testIndepGoals3 "indepGoals3"+        , runTest $ testIndepGoals4 "indepGoals4"+        , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder+        ]+      -- Tests designed for the backjumping blog post+    , testGroup "Backjumping" [+          runTest $         mkTest dbBJ1a "bj1a" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1b "bj1b" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1c "bj1c" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ2  "bj2"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ3  "bj3"  ["A"]      (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)])+        , runTest $         mkTest dbBJ4  "bj4"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ5  "bj5"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("D", 1)])+        , runTest $         mkTest dbBJ6  "bj6"  ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ7  "bj7"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $ indep $ mkTest dbBJ8  "bj8"  ["A", "B"] (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        ]+    , testGroup "main library dependencies" [+          let db = [Right $ exAvNoLibrary "A" 1 `withExe` exExe "exe" []]+          in runTest $ mkTest db "install build target without a library" ["A"] $+             solverSuccess [("A", 1)]++        , let db = [ Right $ exAv "A" 1 [ExAny "B"]+                   , Right $ exAvNoLibrary "B" 1 `withExe` exExe "exe" [] ]+          in runTest $ mkTest db "reject build-depends dependency with no library" ["A"] $+             solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)")++        , let exe = exExe "exe" []+              db = [ Right $ exAv "A" 1 [ExAny "B"]+                   , Right $ exAvNoLibrary "B" 2 `withExe` exe+                   , Right $ exAv "B" 1 [] `withExe` exe ]+          in runTest $ mkTest db "choose version of build-depends dependency that has a library" ["A"] $+             solverSuccess [("A", 1), ("B", 1)]+        ]+    , testGroup "sub-library dependencies" [+          let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]+                   , Right $ exAv "B" 1 [] ]+          in runTest $+             mkTest db "reject package that is missing required sub-library" ["A"] $+             solverFailure $ isInfixOf $+             "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)"++        , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]+                   , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" [] ]+          in runTest $+             mkTest db "reject package with private but required sub-library" ["A"] $+             solverFailure $ isInfixOf $+             "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"++        , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]+                   , Right $ exAvNoLibrary "B" 1+                       `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ]+          in runTest $ constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $+             mkTest db "reject package with sub-library made private by flag constraint" ["A"] $+             solverFailure $ isInfixOf $+             "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"++        , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]+                   , Right $ exAvNoLibrary "B" 1+                       `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ]+          in runTest $+             mkTest db "treat sub-library as visible even though flag choice could make it private" ["A"] $+             solverSuccess [("A", 1), ("B", 1)]++        , let db = [ Right $ exAv "A" 1 [ExAny "B"]+                   , Right $ exAv "B" 1 [] `withSubLibrary` exSubLib "sub-lib" []+                   , Right $ exAv "C" 1 [ExSubLibAny "B" "sub-lib"] ]+              goals :: [ExampleVar]+              goals = [+                  P QualNone "A"+                , P QualNone "B"+                , P QualNone "C"+                ]+          in runTest $ goalOrder goals $+             mkTest db "reject package that requires a private sub-library" ["A", "C"] $+             solverFailure $ isInfixOf $+             "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)"++        , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"]+                   , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies+                   , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib-v1" publicDependencies ]+          in runTest $ mkTest db "choose version of package containing correct sub-library" ["A"] $+             solverSuccess [("A", 1), ("B", 1)]++        , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]+                   , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib" (dependencies [])+                   , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib" publicDependencies ]+          in runTest $ mkTest db "choose version of package with public sub-library" ["A"] $+             solverSuccess [("A", 1), ("B", 1)]+        ]+    -- build-tool-depends dependencies+    , testGroup "build-tool-depends" [+          runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)])++        , runTest $ disableSolveExecutables $+          mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)])++        , runTest $ enableAllTests $+          mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)])++        , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $+          solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by D")++        , runTest $ disableSolveExecutables $+          mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)]++        , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $+          solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)")++        , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $+          solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by F +flagF")++        , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $+          solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by G *test")++        , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $+          solverFailure $ isInfixOf $+              -- The solver reports the version conflict when a version conflict+              -- and an executable conflict apply to the same package version.+              "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"+           ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n"+           ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"++        , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"++        , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"++        , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"++        , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package"+    ]+    -- build-tools dependencies+    , testGroup "legacy build-tools" [+          runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])++        , runTest $ disableSolveExecutables $+          mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $+          solverFailure (isInfixOf "does not contain executable 'alex', which is required by A")++        , runTest $ disableSolveExecutables $+          mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)])++        , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])++        , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])++        , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])+        ]+      -- internal dependencies+    , testGroup "internal dependencies" [+          runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])+        ]+      -- tests for partial fix for issue #5325+    , testGroup "Components that are unbuildable in the current environment" $+      let flagConstraint = ExFlagConstraint . ScopeAnyQualifier+      in [+          let db = [ Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ]+          in runTest $ constraints [flagConstraint "A" "build-lib" False] $+             mkTest db "install unbuildable library" ["A"] $+             solverSuccess [("A", 1)]++        , let db = [ Right $ exAvNoLibrary "A" 1+                       `withExe` exExe "exe" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ]+          in runTest $ constraints [flagConstraint "A" "build-exe" False] $+             mkTest db "install unbuildable exe" ["A"] $+             solverSuccess [("A", 1)]++        , let db = [ Right $ exAv "A" 1 [ExAny "B"]+                   , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ]+          in runTest $ constraints [flagConstraint "B" "build-lib" False] $+             mkTest db "reject library dependency with unbuildable library" ["A"] $+             solverFailure $ isInfixOf $+                   "rejecting: B-1.0.0 (library is not buildable in the "+                ++ "current environment, but it is required by A)"++        , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]+                   , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]+                       `withExe` exExe "bt" [] ]+          in runTest $ constraints [flagConstraint "B" "build-lib" False] $+             mkTest db "allow build-tool dependency with unbuildable library" ["A"] $+             solverSuccess [("A", 1), ("B", 1)]++        , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]+                   , Right $ exAv "B" 1 []+                       `withExe` exExe "bt" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ]+          in runTest $ constraints [flagConstraint "B" "build-exe" False] $+             mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $+             solverFailure $ isInfixOf $+                   "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not "+                ++ "buildable in the current environment, but it is required by A)"+        , runTest $+          chooseUnbuildableExeAfterBuildToolsPackage+          "choose unbuildable exe after choosing its package"+        ]++    , testGroup "--fine-grained-conflicts" [++          -- Skipping a version because of a problematic dependency:+          --+          -- When the solver explores A-4, it finds that it cannot satisfy B's+          -- dependencies. This allows the solver to skip the subsequent+          -- versions of A that also depend on B.+          runTest $+              let db = [+                      Right $ exAv "A" 4 [ExAny "B"]+                    , Right $ exAv "A" 3 [ExAny "B"]+                    , Right $ exAv "A" 2 [ExAny "B"]+                    , Right $ exAv "A" 1 []+                    , Right $ exAv "B" 2 [ExAny "unknown1"]+                    , Right $ exAv "B" 1 [ExAny "unknown2"]+                    ]+                  msg = [+                      "[__0] trying: A-4.0.0 (user goal)"+                    , "[__1] trying: B-2.0.0 (dependency of A)"+                    , "[__2] unknown package: unknown1 (dependency of B)"+                    , "[__2] fail (backjumping, conflict set: B, unknown1)"+                    , "[__1] trying: B-1.0.0"+                    , "[__2] unknown package: unknown2 (dependency of B)"+                    , "[__2] fail (backjumping, conflict set: B, unknown2)"+                    , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"+                    , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "+                       ++ "caused the previous version to fail: depends on 'B')"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] done"+                    ]+              in setVerbose $+                 mkTest db "skip version due to problematic dependency" ["A"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1)]++        , -- Skipping a version because of a restrictive constraint on a+          -- dependency:+          --+          -- The solver rejects A-4 because its constraint on B excludes B-1.+          -- Then the solver is able to skip A-3 and A-2 because they also+          -- exclude B-1, even though they don't have the exact same constraints+          -- on B.+          runTest $+              let db = [+                      Right $ exAv "A" 4 [ExFix "B" 14]+                    , Right $ exAv "A" 3 [ExFix "B" 13]+                    , Right $ exAv "A" 2 [ExFix "B" 12]+                    , Right $ exAv "A" 1 [ExFix "B" 11]+                    , Right $ exAv "B" 11 []+                    ]+                  msg = [+                      "[__0] trying: A-4.0.0 (user goal)"+                    , "[__1] next goal: B (dependency of A)"+                    , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"+                    , "[__1] fail (backjumping, conflict set: A, B)"+                    , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "+                       ++ "caused the previous version to fail: depends on 'B' but excludes "+                       ++ "version 11.0.0)"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] next goal: B (dependency of A)"+                    , "[__1] trying: B-11.0.0"+                    , "[__2] done"+                    ]+              in setVerbose $+                 mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 11)]++        , -- This test tests the case where the solver chooses a version for one+          -- package, B, before choosing a version for one of its reverse+          -- dependencies, C. While the solver is exploring the subtree rooted+          -- at B-3, it finds that C-2's dependency on B conflicts with B-3.+          -- Then the solver is able to skip C-1, because it also excludes B-3.+          --+          -- --fine-grained-conflicts could have a benefit in this case even+          -- though the solver would have found the conflict between B-3 and C-1+          -- immediately after trying C-1 anyway. It prevents C-1 from+          -- introducing any other conflicts which could increase the size of+          -- the conflict set.+          runTest $+              let db = [+                      Right $ exAv "A" 1 [ExAny "B", ExAny "C"]+                    , Right $ exAv "B" 3 []+                    , Right $ exAv "B" 2 []+                    , Right $ exAv "B" 1 []+                    , Right $ exAv "C" 2 [ExFix "B" 2]+                    , Right $ exAv "C" 1 [ExFix "B" 1]+                    ]+                  goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]+                  expectedMsg = [+                      "[__0] trying: A-1.0.0 (user goal)"+                    , "[__1] trying: B-3.0.0 (dependency of A)"+                    , "[__2] next goal: C (dependency of A)"+                    , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)"+                    , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the "+                       ++ "previous version to fail: excludes 'B' version 3.0.0)"+                    , "[__2] fail (backjumping, conflict set: A, B, C)"+                    , "[__1] trying: B-2.0.0"+                    , "[__2] next goal: C (dependency of A)"+                    , "[__2] trying: C-2.0.0"+                    , "[__3] done"+                    ]+              in setVerbose $ goalOrder goals $+                 mkTest db "skip version that excludes dependency that was already chosen" ["A"] $+                 SolverResult (isInfixOf expectedMsg) $ Right [("A", 1), ("B", 2), ("C", 2)]++        , -- This test tests how the solver merges conflicts when it has+          -- multiple reasons to add a variable to the conflict set. In this+          -- case, package A conflicts with B and C. The solver should take the+          -- union of the conflicts and then only skip a version if it does not+          -- resolve any of the conflicts.+          --+          -- The solver rejects A-3 because it can't find consistent versions for+          -- its two dependencies, B and C. Then it skips A-2 because A-2 also+          -- depends on B and C. This test ensures that the solver considers+          -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes+          -- the dependency on C).+          runTest $+              let db = [+                      Right $ exAv "A" 3 [ExAny "B", ExAny "C"]+                    , Right $ exAv "A" 2 [ExAny "B", ExAny "C"]+                    , Right $ exAv "A" 1 [ExAny "B"]+                    , Right $ exAv "B" 1 [ExFix "D" 1]+                    , Right $ exAv "C" 1 [ExFix "D" 2]+                    , Right $ exAv "D" 1 []+                    , Right $ exAv "D" 2 []+                    ]+                  goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]+                  msg = [+                      "[__0] trying: A-3.0.0 (user goal)"+                    , "[__1] trying: B-1.0.0 (dependency of A)"+                    , "[__2] trying: C-1.0.0 (dependency of A)"+                    , "[__3] next goal: D (dependency of B)"+                    , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"+                    , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)"+                    , "[__3] fail (backjumping, conflict set: B, C, D)"+                    , "[__2] fail (backjumping, conflict set: A, B, C, D)"+                    , "[__1] fail (backjumping, conflict set: A, B, C, D)"+                    , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the "+                       ++ "previous version to fail: depends on 'B'; depends on 'C')"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] trying: B-1.0.0 (dependency of A)"+                    , "[__2] next goal: D (dependency of B)"+                    , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"+                    , "[__2] trying: D-1.0.0"+                    , "[__3] done"+                    ]+              in setVerbose $ goalOrder goals $+                 mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1), ("D", 1)]++        , -- This test ensures that the solver log doesn't show all conflicts+          -- that the solver encountered in a subtree. The solver should only+          -- show the conflicts that are contained in the current conflict set.+          --+          -- The goal order forces the solver to try A-4, encounter a conflict+          -- with B-2, try B-1, and then try C. A-4 conflicts with the only+          -- version of C, so the solver backjumps with a conflict set of+          -- {A, C}. When the solver skips the next version of A, the log should+          -- mention the conflict with C but not B.+          runTest $+              let db = [+                      Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1]+                    , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1]+                    , Right $ exAv "A" 2 [ExFix "C" 1]+                    , Right $ exAv "A" 1 [ExFix "C" 2]+                    , Right $ exAv "B" 2 []+                    , Right $ exAv "B" 1 []+                    , Right $ exAv "C" 2 []+                    ]+                  goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]+                  msg = [+                      "[__0] trying: A-4.0.0 (user goal)"+                    , "[__1] next goal: B (dependency of A)"+                    , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"+                    , "[__1] trying: B-1.0.0"+                    , "[__2] next goal: C (dependency of A)"+                    , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"+                    , "[__2] fail (backjumping, conflict set: A, C)"+                    , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the "+                       ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] next goal: C (dependency of A)"+                    , "[__1] trying: C-2.0.0"+                    , "[__2] done"+                    ]+              in setVerbose $ goalOrder goals $+                 mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1), ("C", 2)]++        , -- Tests that the conflict set is properly updated when a version is+          -- skipped due to being excluded by one of its reverse dependencies'+          -- constraints.+          runTest $+              let db = [+                      Right $ exAv "A" 2 [ExFix "B" 3]+                    , Right $ exAv "A" 1 [ExFix "B" 1]+                    , Right $ exAv "B" 2 []+                    , Right $ exAv "B" 1 []+                    ]+                  msg = [+                      "[__0] trying: A-2.0.0 (user goal)"+                    , "[__1] next goal: B (dependency of A)"++                      -- During this step, the solver adds A and B to the+                      -- conflict set, with the details of each package's+                      -- conflict:+                      --+                      -- A: A's constraint rejected B-2.+                      -- B: B was rejected by A's B==3 constraint+                    , "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)"++                      -- When the solver skips B-1, it cannot simply reuse the+                      -- previous conflict set. It also needs to update A's+                      -- entry to say that A also rejected B-1. Otherwise, the+                      -- solver wouldn't know that A-1 could resolve one of+                      -- the conflicts encountered while exploring A-2. The+                      -- solver would skip A-1, even though it leads to the+                      -- solution.+                    , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "+                       ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')"++                    , "[__1] fail (backjumping, conflict set: A, B)"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] next goal: B (dependency of A)"+                    , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"+                    , "[__1] trying: B-1.0.0"+                    , "[__2] done"+                    ]+              in setVerbose $+                 mkTest db "update conflict set after skipping version - 1" ["A"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)]++        , -- Tests that the conflict set is properly updated when a version is+          -- skipped due to excluding a version of one of its dependencies.+          -- This test is similar the previous one, with the goal order reversed.+          runTest $+              let db = [+                      Right $ exAv "A" 2 []+                    , Right $ exAv "A" 1 []+                    , Right $ exAv "B" 2 [ExFix "A" 3]+                    , Right $ exAv "B" 1 [ExFix "A" 1]+                    ]+                  goals = [P QualNone pkg | pkg <- ["A", "B"]]+                  msg = [+                      "[__0] trying: A-2.0.0 (user goal)"+                    , "[__1] next goal: B (user goal)"+                    , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)"+                    , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "+                       ++ "the previous version to fail: excludes 'A' version 2.0.0)"+                    , "[__1] fail (backjumping, conflict set: A, B)"+                    , "[__0] trying: A-1.0.0"+                    , "[__1] next goal: B (user goal)"+                    , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)"+                    , "[__1] trying: B-1.0.0"+                    , "[__2] done"+                    ]+              in setVerbose $ goalOrder goals $+                 mkTest db "update conflict set after skipping version - 2" ["A", "B"] $+                 SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)]+        ]+      -- Tests for the contents of the solver's log+    , testGroup "Solver log" [+          -- See issue #3203. The solver should only choose a version for A once.+          runTest $+              let db = [Right $ exAv "A" 1 []]++                  p :: [String] -> Bool+                  p lg =    elem "targets: A" lg+                         && length (filter ("trying: A" `isInfixOf`) lg) == 1+              in setVerbose $ mkTest db "deduplicate targets" ["A", "A"] $+                 SolverResult p $ Right [("A", 1)]+        , runTest $+              let db = [Right $ exAv "A" 1 [ExAny "B"]]+                  msg = "After searching the rest of the dependency tree exhaustively, "+                     ++ "these were the goals I've had most trouble fulfilling: A, B"+              in mkTest db "exhaustive search failure message" ["A"] $+                 solverFailure (isInfixOf msg)+        , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $+                "Could not resolve dependencies:\n"+             ++ "[__0] trying: A-1.0.0 (user goal)\n"+             ++ "[__1] unknown package: F (dependency of A)\n"+             ++ "[__1] fail (backjumping, conflict set: A, F)\n"+             ++ "After searching the rest of the dependency tree exhaustively, "+             ++ "these were the goals I've had most trouble fulfilling: A, F"+        , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $+                "Could not resolve dependencies:\n"+             ++ "[__0] trying: A-1.0.0 (user goal)\n"+             ++ "[__1] trying: B-3.0.0 (dependency of A)\n"+             ++ "[__2] unknown package: C (dependency of B)\n"+             ++ "[__2] fail (backjumping, conflict set: B, C)\n"+             ++ "Backjump limit reached (currently 3, change with --max-backjumps "+             ++ "or try to run with --reorder-goals).\n"+        , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $+                "Backjump limit reached (currently 1, change with --max-backjumps "+             ++ "or try to run with --reorder-goals).\n"+             ++ "Failed to generate a summarized dependency solver log due to low backjump limit."+        , testMinimizeConflictSet+              "minimize conflict set with --minimize-conflict-set"+        , testNoMinimizeConflictSet+              "show original conflict set with --no-minimize-conflict-set"+        , runTest $+              let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]+                       , Left $ exInst "other-package" 2 "other-package-2.0.0" []]+                  msg = "rejecting: other-package-2.0.0/installed-2.0.0"+              in mkTest db "show full installed package version (issue #5892)" ["my-package"] $+                 solverFailure (isInfixOf msg)+        , runTest $+              let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]+                       , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" [] ]+                  msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"+              in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $+                 solverFailure (isInfixOf msg)+        ]+    ]+  where+    indep           = independentGoals+    mkvrThis        = V.thisVersion . makeV+    mkvrOrEarlier   = V.orEarlierVersion . makeV+    makeV v         = V.mkVersion [v,0,0]++data GoalOrder = FixedGoalOrder | DefaultGoalOrder++{-------------------------------------------------------------------------------+  Specific example database for the tests+-------------------------------------------------------------------------------}++db1 :: ExampleDb+db1 =+    let a = exInst "A" 1 "A-1" []+    in [ Left a+       , Right $ exAv "B" 1 [ExAny "A"]+       , Right $ exAv "B" 2 [ExAny "A"]+       , Right $ exAv "C" 1 [ExFix "B" 1]+       , Right $ exAv "D" 1 [ExFix "B" 2]+       , Right $ exAv "E" 1 [ExAny "B"]+       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]+       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]+       , Right $ exAv "Z" 1 []+       ]++-- In this example, we _can_ install C and D as independent goals, but we have+-- to pick two different versions for B (arbitrarily)+db2 :: ExampleDb+db2 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]+  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]+  ]++db3 :: ExampleDb+db3 = [+     Right $ exAv "A" 1 []+   , Right $ exAv "A" 2 []+   , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]]+   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]+   ]++-- | Like db3, but the flag picks a different package rather than a+-- different package version+--+-- In db3 we cannot install C and D as independent goals because:+--+-- * The multiple instance restriction says C and D _must_ share B+-- * Since C relies on A-1, C needs B to be compiled with flagB on+-- * Since D relies on A-2, D needs B to be compiled with flagB off+-- * Hence C and D have incompatible requirements on B's flags.+--+-- However, _even_ if we don't check explicitly that we pick the same flag+-- assignment for 0.B and 1.B, we will still detect the problem because+-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to+-- 1.A and therefore we cannot link 0.B to 1.B.+--+-- In db4 the situation however is trickier. We again cannot install+-- packages C and D as independent goals because:+--+-- * As above, the multiple instance restriction says that C and D _must_ share B+-- * Since C relies on Ax-2, it requires B to be compiled with flagB off+-- * Since D relies on Ay-2, it requires B to be compiled with flagB on+-- * Hence C and D have incompatible requirements on B's flags.+--+-- But now this requirement is more indirect. If we only check dependencies+-- we don't see the problem:+--+-- * We link 0.B to 1.B+-- * 0.B relies on Ay-1+-- * 1.B relies on Ax-1+--+-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since+-- we only ever assign to one of these, these constraints are never broken.+db4 :: ExampleDb+db4 = [+     Right $ exAv "Ax" 1 []+   , Right $ exAv "Ax" 2 []+   , Right $ exAv "Ay" 1 []+   , Right $ exAv "Ay" 2 []+   , Right $ exAv "B"  1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]+   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]+   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]+   ]++-- | Simple database containing one package with a manual flag.+dbManualFlags :: ExampleDb+dbManualFlags = [+    Right $ declareFlags [ExFlag "flag" True Manual] $+        exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]]+  , Right $ exAv "true-dep"  1 []+  , Right $ exAv "false-dep" 1 []+  ]++-- | Database containing a setup dependency with a manual flag. A's library and+-- setup script depend on two different versions of B. B's manual flag can be+-- set to different values in the two places where it is used.+dbSetupDepWithManualFlag :: ExampleDb+dbSetupDepWithManualFlag =+  let bFlags = [ExFlag "flag" True Manual]+  in [+      Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2]+    , Right $ declareFlags bFlags $+          exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]+                                       [ExAny "b-1-false-dep"]]+    , Right $ declareFlags bFlags $+          exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"]+                                       [ExAny "b-2-false-dep"]]+    , Right $ exAv "b-1-true-dep"  1 []+    , Right $ exAv "b-1-false-dep" 1 []+    , Right $ exAv "b-2-true-dep"  1 []+    , Right $ exAv "b-2-false-dep" 1 []+    ]++-- | A database similar to 'dbSetupDepWithManualFlag', except that the library+-- and setup script both depend on B-1. B must be linked because of the Single+-- Instance Restriction, and its flag can only have one value.+dbLinkedSetupDepWithManualFlag :: ExampleDb+dbLinkedSetupDepWithManualFlag = [+    Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1]+  , Right $ declareFlags [ExFlag "flag" True Manual] $+        exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]+                                     [ExAny "b-1-false-dep"]]+  , Right $ exAv "b-1-true-dep"  1 []+  , Right $ exAv "b-1-false-dep" 1 []+  ]++-- | Some tests involving testsuites+--+-- Note that in this test framework test suites are always enabled; if you+-- want to test without test suites just set up a test database without+-- test suites.+--+-- * C depends on A (through its test suite)+-- * D depends on B-2 (through its test suite), but B-2 is unavailable+-- * E depends on A-1 directly and on A through its test suite. We prefer+--     to use A-1 for the test suite in this case.+-- * F depends on A-1 directly and on A-2 through its test suite. In this+--     case we currently fail to install F, although strictly speaking+--     test suites should be considered independent goals.+-- * G is like E, but for version A-2. This means that if we cannot install+--     E and G together, unless we regard them as independent goals.+db5 :: ExampleDb+db5 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExAny "A"]+  , Right $ exAv "D" 1 [] `withTest` exTest "testD" [ExFix "B" 2]+  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` exTest "testE" [ExAny "A"]+  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` exTest "testF" [ExFix "A" 2]+  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` exTest "testG" [ExAny "A"]+  ]++-- Now the _dependencies_ have test suites+--+-- * Installing C is a simple example. C wants version 1 of A, but depends on+--   B, and B's testsuite depends on an any version of A. In this case we prefer+--   to link (if we don't regard test suites as independent goals then of course+--   linking here doesn't even come into it).+-- * Installing [C, D] means that we prefer to link B -- depending on how we+--   set things up, this means that we should also link their test suites.+db6 :: ExampleDb+db6 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [] `withTest` exTest "testA" [ExAny "A"]+  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+  , Right $ exAv "D" 1 [ExAny "B"]+  ]++-- | This test checks that the solver can backjump to disable a flag, even if+-- the problematic dependency is also under a test suite. (issue #4390)+--+-- The goal order forces the solver to choose the flag before enabling testing.+-- Previously, the solver couldn't handle this case, because it only tried to+-- disable testing, and when that failed, it backjumped past the flag choice.+-- The solver should also try to set the flag to false, because that avoids the+-- dependency on B.+testTestSuiteWithFlag :: String -> SolverTest+testTestSuiteWithFlag name =+    goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $+    solverSuccess [("A", 1), ("B", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 []+          `withTest`+            exTest "test" [exFlagged "flag" [ExFix "B" 2] []]+      , Right $ exAv "B" 1 []+      ]++    goals :: [ExampleVar]+    goals = [+        P QualNone "B"+      , P QualNone "A"+      , F QualNone "A" "flag"+      , S QualNone "A" TestStanzas+      ]++-- Packages with setup dependencies+--+-- Install..+-- * B: Simple example, just make sure setup deps are taken into account at all+-- * C: Both the package and the setup script depend on any version of A.+--      In this case we prefer to link+-- * D: Variation on C.1 where the package requires a specific (not latest)+--      version but the setup dependency is not fixed. Again, we prefer to+--      link (picking the older version)+-- * E: Variation on C.2 with the setup dependency the more inflexible.+--      Currently, in this case we do not see the opportunity to link because+--      we consider setup dependencies after normal dependencies; we will+--      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick+--      A.1 instead. This isn't so easy to fix (if we want to fix it at all);+--      in particular, considering setup dependencies _before_ other deps is+--      not an improvement, because in general we would prefer to link setup+--      setups to package deps, rather than the other way around. (For example,+--      if we change this ordering then the test for D would start to install+--      two versions of A).+-- * F: The package and the setup script depend on different versions of A.+--      This will only work if setup dependencies are considered independent.+db7 :: ExampleDb+db7 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]+  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+  ]++-- If we install C and D together (not as independent goals), we need to build+-- both B.1 and B.2, both of which depend on A.+db8 :: ExampleDb+db8 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]+  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]+  ]++-- Extended version of `db8` so that we have nested setup dependencies+db9 :: ExampleDb+db9 = db8 ++ [+    Right $ exAv "E" 1 [ExAny "C"]+  , Right $ exAv "E" 2 [ExAny "D"]+  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]+  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]+  ]++-- Multiple already-installed packages with inter-dependencies, and one package+-- (C) that depends on package A-1 for its setup script and package A-2 as a+-- library dependency.+db10 :: ExampleDb+db10 =+  let rts         = exInst "rts"         1 "rts-inst"         []+      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]+      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]+      a1          = exInst "A"           1 "A1-inst"          [base]+      a2          = exInst "A"           2 "A2-inst"          [base]+  in [+      Left rts+    , Left ghc_prim+    , Left base+    , Left a1+    , Left a2+    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+    ]++-- | This database tests that a package's setup dependencies are correctly+-- linked when the package is linked. See pull request #3268.+--+-- When A and B are installed as independent goals, their dependencies on C must+-- be linked, due to the single instance restriction. Since C depends on D, 0.D+-- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D+-- and 1.C-setup.D must be linked. However, D's two link groups must remain+-- independent. The solver should be able to choose D-1 for C's library and D-2+-- for C's setup script.+dbSetupDeps :: ExampleDb+dbSetupDeps = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  ]++-- | Tests for dealing with base shims+db11 :: ExampleDb+db11 =+  let base3 = exInst "base" 3 "base-3-inst" [base4]+      base4 = exInst "base" 4 "base-4-inst" []+  in [+      Left base3+    , Left base4+    , Right $ exAv "A" 1 [ExFix "base" 3]+    ]++-- | Slightly more realistic version of db11 where base-3 depends on syb+-- This means that if a package depends on base-3 and on syb, then they MUST+-- share the version of syb+--+-- * Package A relies on base-3 (which relies on base-4)+-- * Package B relies on base-4+-- * Package C relies on both A and B+-- * Package D relies on base-3 and on syb-2, which is not possible because+--     base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)+-- * Package E relies on base-4 and on syb-2, which is fine.+db12 :: ExampleDb+db12 =+  let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]+      base4 = exInst "base" 4 "base-4-inst" []+      syb1  = exInst "syb" 1 "syb-1-inst" [base4]+  in [+      Left base3+    , Left base4+    , Left syb1+    , Right $ exAv "syb" 2 [ExFix "base" 4]+    , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]+    , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]+    , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+    , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]+    , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]+    ]++dbBase :: ExampleDb+dbBase = [+      Right $ exAv "base" 1+              [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"]+    , Right $ exAv "ghc-prim" 1 []+    , Right $ exAv "integer-simple" 1 []+    , Right $ exAv "integer-gmp" 1 []+    ]++db13 :: ExampleDb+db13 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "A" 3 []+  ]++-- | A, B, and C have three different dependencies on D that can be set to+-- different versions with qualified constraints. Each version of D can only+-- be depended upon by one version of A, B, or C, so that the versions of A, B,+-- and C in the install plan indicate which version of D was chosen for each+-- dependency. The one-to-one correspondence between versions of A, B, and C and+-- versions of D also prevents linking, which would complicate the solver's+-- behavior.+dbConstraints :: ExampleDb+dbConstraints =+    [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]]+ ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]]+ ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]]+ ++ [Right $ exAv "D" v [] | v <- [1..9]]++dbStanzaPreferences1 :: ExampleDb+dbStanzaPreferences1 = [+    Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "test-dep"]+  , Right $ exAv "test-dep" 1 []+  ]++dbStanzaPreferences2 :: ExampleDb+dbStanzaPreferences2 = [+    Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "unknown"]+  ]++-- | This is a test case for a bug in stanza preferences (#3930). The solver+-- should be able to install 'A' by enabling 'flag' and disabling testing. When+-- it tries goals in the specified order and prefers testing, it encounters+-- 'unknown-pkg2'. 'unknown-pkg2' is only introduced by testing and 'flag', so+-- the conflict set should contain both of those variables. Before the fix, it+-- only contained 'flag'. The solver backjumped past the choice to disable+-- testing and failed to find the solution.+testStanzaPreference :: String -> TestTree+testStanzaPreference name =+  let pkg = exAv "A" 1    [exFlagged "flag"+                              []+                              [ExAny "unknown-pkg1"]]+             `withTest`+            exTest "test" [exFlagged "flag"+                              [ExAny "unknown-pkg2"]+                              []]+      goals = [+          P QualNone "A"+        , F QualNone "A" "flag"+        , S QualNone "A" TestStanzas+        ]+  in runTest $ goalOrder goals $+     preferences [ ExStanzaPref "A" [TestStanzas]] $+     mkTest [Right pkg] name ["A"] $+     solverSuccess [("A", 1)]++-- | Database with some cycles+--+-- * Simplest non-trivial cycle: A -> B and B -> A+-- * There is a cycle C -> D -> C, but it can be broken by picking the+--   right flag assignment.+db14 :: ExampleDb+db14 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]]+  , Right $ exAv "D" 1 [ExAny "C"]+  , Right $ exAv "E" 1 []+  ]++-- | Cycles through setup dependencies+--+-- The first cycle is unsolvable: package A has a setup dependency on B,+-- B has a regular dependency on A, and we only have a single version available+-- for both.+--+-- The second cycle can be broken by picking different versions: package C-2.0+-- has a setup dependency on D, and D has a regular dependency on C-*. However,+-- version C-1.0 is already available (perhaps it didn't have this setup dep).+-- Thus, we should be able to break this cycle even if we are installing package+-- E, which explicitly depends on C-2.0.+db15 :: ExampleDb+db15 = [+    -- First example (real cycle, no solution)+    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]+  , Right $ exAv   "B" 1            [ExAny "A"]+    -- Second example (cycle can be broken by picking versions carefully)+  , Left  $ exInst "C" 1 "C-1-inst" []+  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]+  , Right $ exAv   "D" 1            [ExAny "C"  ]+  , Right $ exAv   "E" 1            [ExFix "C" 2]+  ]++-- | Detect a cycle between a package and its setup script.+--+-- This type of cycle can easily occur when v2-build adds default setup+-- dependencies to packages without custom-setup stanzas. For example, cabal+-- adds 'time' as a setup dependency for 'time'. The solver should detect the+-- cycle when it attempts to link the setup and non-setup instances of the+-- package and then choose a different version for the setup dependency.+issue4161 :: String -> SolverTest+issue4161 name =+    setVerbose $ mkTest db name ["target"] $+    SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "target" 1 [ExFix "time" 2]+      , Right $ exAv "time"   2 []               `withSetupDeps` [ExAny "time"]+      , Right $ exAv "time"   1 []+      ]++    checkFullLog :: [String] -> Bool+    checkFullLog = any $ isInfixOf $+        "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "+                ++ "conflict set: time:setup.time)"++-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack+-- as soon as it chooses the last package in the cycle, to avoid searching parts+-- of the tree that have no solution. Since there is no way to break the cycle,+-- it should fail with an error message describing the cycle.+testCyclicDependencyErrorMessages :: String -> SolverTest+testCyclicDependencyErrorMessages name =+    goalOrder goals $+    mkTest db name ["pkg-A"] $+    SolverResult checkFullLog $ Left checkSummarizedLog+  where+    db :: ExampleDb+    db = [+        Right $ exAv "pkg-A" 1 [ExAny "pkg-B"]+      , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"]+      , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"]+      , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"]+      , Right $ exAv "pkg-E" 1 []+      ]++    -- The solver should backtrack as soon as pkg-A, pkg-B, and pkg-C form a+    -- cycle. It shouldn't try pkg-D or pkg-E.+    checkFullLog :: [String] -> Bool+    checkFullLog =+        not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l)++    checkSummarizedLog :: String -> Bool+    checkSummarizedLog =+        isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"++    -- Solve for pkg-D and pkg-E last.+    goals :: [ExampleVar]+    goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']]++-- | Check that the solver can backtrack after encountering the SIR (issue #2843)+--+-- When A and B are installed as independent goals, the single instance+-- restriction prevents B from depending on C.  This database tests that the+-- solver can backtrack after encountering the single instance restriction and+-- choose the only valid flag assignment (-flagA +flagB):+--+-- > flagA flagB  B depends on+-- >  On    _     C-*+-- >  Off   On    E-*               <-- only valid flag assignment+-- >  Off   Off   D-2.0, C-*+--+-- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D,+-- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have+-- C in the transitive closure of B's dependencies, because that would mean we+-- would need two instances of C: one built against D-1.0 and one built against+-- D-2.0.+db16 :: ExampleDb+db16 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ ExFix "D" 2+                       , exFlagged "flagA"+                             [ExAny "C"]+                             [exFlagged "flagB"+                                 [ExAny "E"]+                                 [ExAny "C"]]]+  , Right $ exAv "C" 1 [ExAny "D"]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  ]+++-- Try to get the solver to backtrack while satisfying+-- reject-unconstrained-dependencies: both the first and last versions of A+-- require packages outside the closed set, so it will have to try the+-- middle one.+db17 :: ExampleDb+db17 = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "A" 2 [ExAny "B"]+  , Right $ exAv "A" 3 [ExAny "C"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 [ExAny "B"]+  ]++-- | This test checks that when the solver discovers a constraint on a+-- package's version after choosing to link that package, it can backtrack to+-- try alternative versions for the linked-to package. See pull request #3327.+--+-- When A and B are installed as independent goals, their dependencies on C+-- must be linked. Since C depends on D, A and B's dependencies on D must also+-- be linked. This test fixes the goal order so that the solver chooses D-2 for+-- both 0.D and 1.D before it encounters the test suites' constraints. The+-- solver must backtrack to try D-1 for both 0.D and 1.D.+testIndepGoals2 :: String -> SolverTest+testIndepGoals2 name =+    goalOrder goals $ independentGoals $+    enableAllTests $ mkTest db name ["A", "B"] $+    solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1]+      , Right $ exAv "B" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1]+      , Right $ exAv "C" 1 [ExAny "D"]+      , Right $ exAv "D" 1 []+      , Right $ exAv "D" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (QualIndep "A") "A"+      , P (QualIndep "A") "C"+      , P (QualIndep "A") "D"+      , P (QualIndep "B") "B"+      , P (QualIndep "B") "C"+      , P (QualIndep "B") "D"+      , S (QualIndep "B") "B" TestStanzas+      , S (QualIndep "A") "A" TestStanzas+      ]++-- | Issue #2834+-- When both A and B are installed as independent goals, their dependencies on+-- C must be linked. The only combination of C's flags that is consistent with+-- A and B's dependencies on D is -flagA +flagB. This database tests that the+-- solver can backtrack to find the right combination of flags (requiring F, but+-- not E or G) and apply it to both 0.C and 1.C.+--+-- > flagA flagB  C depends on+-- >  On    _     D-1, E-*+-- >  Off   On    F-*        <-- Only valid choice+-- >  Off   Off   D-2, G-*+--+-- The single instance restriction means we cannot have one instance of C+-- built against D-1 and one instance built against D-2; since A depends on+-- D-1, and B depends on C-2, it is therefore important that C cannot depend+-- on any version of D.+db18 :: ExampleDb+db18 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]+  , Right $ exAv "C" 1 [exFlagged "flagA"+                           [ExFix "D" 1, ExAny "E"]+                           [exFlagged "flagB"+                               [ExAny "F"]+                               [ExFix "D" 2, ExAny "G"]]]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  , Right $ exAv "F" 1 []+  , Right $ exAv "G" 1 []+  ]++-- | When both values for flagA introduce package B, the solver should be able+-- to choose B before choosing a value for flagA. It should try to choose a+-- version for B that is in the union of the version ranges required by +flagA+-- and -flagA.+commonDependencyLogMessage :: String -> SolverTest+commonDependencyLogMessage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "[__0] trying: A-1.0.0 (user goal)\n"+     ++ "[__1] next goal: B (dependency of A +/-flagA)\n"+     ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [ExFix "B" 1]+                               [ExFix "B" 3]]+      , Right $ exAv "B" 2 []+      ]++-- | Test lifting dependencies out of multiple levels of conditionals.+twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest+twoLevelDeepCommonDependencyLogMessage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "unknown package: B (dependency of A +/-flagA +/-flagB)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [exFlagged "flagB"+                                   [ExAny "B"]+                                   [ExAny "B"]]+                               [exFlagged "flagB"+                                   [ExAny "B"]+                                   [ExAny "B"]]]+      ]++-- | Test handling nested conditionals that are controlled by the same flag.+-- The solver should treat flagA as introducing 'unknown' with value true, not+-- both true and false. That means that when +flagA causes a conflict, the+-- solver should try flipping flagA to false to resolve the conflict, rather+-- than backjumping past flagA.+testBackjumpingWithCommonDependency :: String -> SolverTest+testBackjumpingWithCommonDependency name =+    mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [exFlagged "flagA"+                               [exFlagged "flagA"+                                   [ExAny "unknown"]+                                   [ExAny "unknown"]]+                               [ExAny "B"]]+      , Right $ exAv "B" 1 []+      ]++-- | Tricky test case with independent goals (issue #2842)+--+-- Suppose we are installing D, E, and F as independent goals:+--+-- * D depends on A-* and C-1, requiring A-1 to be built against C-1+-- * E depends on B-* and C-2, requiring B-1 to be built against C-2+-- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built+--     against the same version of C, violating the single instance restriction.+--+-- We can visualize this DB as:+--+-- >    C-1   C-2+-- >    /|\   /|\+-- >   / | \ / | \+-- >  /  |  X  |  \+-- > |   | / \ |   |+-- > |   |/   \|   |+-- > |   +     +   |+-- > |   |     |   |+-- > |   A     B   |+-- >  \  |\   /|  /+-- >   \ | \ / | /+-- >    \|  V  |/+-- >     D  F  E+testIndepGoals3 :: String -> SolverTest+testIndepGoals3 name =+    goalOrder goals $ independentGoals $+    mkTest db name ["D", "E", "F"] anySolverFailure+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]+      , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]+      , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]+      ]++    goals :: [ExampleVar]+    goals = [+        P (QualIndep "D") "D"+      , P (QualIndep "D") "C"+      , P (QualIndep "D") "A"+      , P (QualIndep "E") "E"+      , P (QualIndep "E") "C"+      , P (QualIndep "E") "B"+      , P (QualIndep "F") "F"+      , P (QualIndep "F") "B"+      , P (QualIndep "F") "C"+      , P (QualIndep "F") "A"+      ]++-- | This test checks that the solver correctly backjumps when dependencies+-- of linked packages are not linked. It is an example where the conflict set+-- from enforcing the single instance restriction is not sufficient. See pull+-- request #3327.+--+-- When A, B, and C are installed as independent goals with the specified goal+-- order, the first choice that the solver makes for E is 0.E-2. Then, when it+-- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally,+-- the solver discovers C's test's constraint on E. It must backtrack to try+-- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead+-- to a solution, because 0.E's version is constrained by A and cannot be+-- changed.+testIndepGoals4 :: String -> SolverTest+testIndepGoals4 name =+    goalOrder goals $ independentGoals $+    enableAllTests $ mkTest db name ["A", "B", "C"] $+    solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExFix "E" 2]+      , Right $ exAv "B" 1 [ExAny "D"]+      , Right $ exAv "C" 1 [ExAny "D"] `withTest` exTest "test" [ExFix "E" 1]+      , Right $ exAv "D" 1 [ExAny "E"]+      , Right $ exAv "E" 1 []+      , Right $ exAv "E" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (QualIndep "A") "A"+      , P (QualIndep "A") "E"+      , P (QualIndep "B") "B"+      , P (QualIndep "B") "D"+      , P (QualIndep "B") "E"+      , P (QualIndep "C") "C"+      , P (QualIndep "C") "D"+      , P (QualIndep "C") "E"+      , S (QualIndep "C") "C" TestStanzas+      ]++-- | Test the trace messages that we get when a package refers to an unknown pkg+--+-- TODO: Currently we don't actually test the trace messages, and this particular+-- test still succeeds. The trace can only be verified by hand.+db21 :: ExampleDb+db21 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown+  , Right $ exAv "B" 1 []+  ]++-- | A variant of 'db21', which actually fails.+db22 :: ExampleDb+db22 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"]+  ]++-- | Another test for the unknown package message.  This database tests that+-- filtering out redundant conflict set messages in the solver log doesn't+-- interfere with generating a message about a missing package (part of issue+-- #3617). The conflict set for the missing package is {A, B}. That conflict set+-- is propagated up the tree to the level of A. Since the conflict set is the+-- same at both levels, the solver only keeps one of the backjumping messages.+db23 :: ExampleDb+db23 = [+    Right $ exAv "A" 1 [ExAny "B"]+  ]++-- | Database for (unsuccessfully) trying to expose a bug in the handling+-- of implied linking constraints. The question is whether an implied linking+-- constraint should only have the introducing package in its conflict set,+-- or also its link target.+--+-- It turns out that as long as the Single Instance Restriction is in place,+-- it does not matter, because there will always be an option that is failing+-- due to the SIR, which contains the link target in its conflict set.+--+-- Even if the SIR is not in place, if there is a solution, one will always+-- be found, because without the SIR, linking is always optional, but never+-- necessary.+--+testIndepGoals5 :: String -> GoalOrder -> SolverTest+testIndepGoals5 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = independentGoals $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (QualIndep "X") "X"+      , P (QualIndep "X") "A"+      , P (QualIndep "X") "B"+      , P (QualIndep "X") "C"+      , P (QualIndep "Y") "Y"+      , P (QualIndep "Y") "A"+      , P (QualIndep "Y") "B"+      , P (QualIndep "Y") "C"+      ]++-- | A simplified version of 'testIndepGoals5'.+testIndepGoals6 :: String -> GoalOrder -> SolverTest+testIndepGoals6 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = independentGoals $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 []+      , Right $ exAv "B" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (QualIndep "X") "X"+      , P (QualIndep "X") "A"+      , P (QualIndep "X") "B"+      , P (QualIndep "Y") "Y"+      , P (QualIndep "Y") "A"+      , P (QualIndep "Y") "B"+      ]++dbExts1 :: ExampleDb+dbExts1 = [+    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]+  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]+  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]+  ]++dbLangs1 :: ExampleDb+dbLangs1 = [+    Right $ exAv "A" 1 [ExLang Haskell2010]+  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]+  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]+  ]++-- | cabal must set enable-exe to false in order to avoid the unavailable+-- dependency. Flags are true by default. The flag choice causes "pkg" to+-- depend on "false-dep".+testBuildable :: String -> ExampleDependency -> TestTree+testBuildable testName unavailableDep =+    runTest $+    mkTestExtLangPC (Just []) (Just [Haskell98]) (Just []) db testName ["pkg"] expected+  where+    expected = solverSuccess [("false-dep", 1), ("pkg", 1)]+    db = [+        Right $ exAv "pkg" 1 [exFlagged "enable-exe"+                                 [ExAny "true-dep"]+                                 [ExAny "false-dep"]]+         `withExe`+            exExe "exe" [ unavailableDep+                        , ExFlagged "enable-exe" (dependencies []) unbuildableDependencies ]+      , Right $ exAv "true-dep" 1 []+      , Right $ exAv "false-dep" 1 []+      ]++-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages+-- "flag1-false" and "flag2-true".+dbBuildable1 :: ExampleDb+dbBuildable1 = [+    Right $ exAv "pkg" 1+        [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]+        , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]+     `withExes`+        [ exExe "exe1"+            [ ExAny "unknown"+            , ExFlagged "flag1" (dependencies []) unbuildableDependencies+            , ExFlagged "flag2" (dependencies []) unbuildableDependencies]+        , exExe "exe2"+            [ ExAny "unknown"+            , ExFlagged "flag1"+                  (dependencies [])+                  (dependencies [ExFlagged "flag2" unbuildableDependencies (dependencies [])])]+         ]+  , Right $ exAv "flag1-true" 1 []+  , Right $ exAv "flag1-false" 1 []+  , Right $ exAv "flag2-true" 1 []+  , Right $ exAv "flag2-false" 1 []+  ]++-- | cabal must pick B-2 to avoid the unknown dependency.+dbBuildable2 :: ExampleDb+dbBuildable2 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "unknown"]+  , Right $ exAv "B" 2 []+     `withExe`+        exExe "exe"+        [ ExAny "unknown"+        , ExFlagged "disable-exe" unbuildableDependencies (dependencies [])+        ]+  , Right $ exAv "B" 3 [ExAny "unknown"]+  ]++-- | Package databases for testing @pkg-config@ dependencies.+-- when no pkgconfig db is present, cabal must pick flag1 false and flag2 true to avoid the pkg dependency.+dbPC1 :: ExampleDb+dbPC1 = [+    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]+  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]+  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  , Right $ exAv "D" 1 [exFlagged "flag1" [ExAny "A"] [], exFlagged "flag2" [] [ExAny "A"]]+  ]++-- | Test for the solver's summarized log. The final conflict set is {A, F},+-- though the goal order forces the solver to find the (avoidable) conflict+-- between B and C first. When the solver reaches the backjump limit, it should+-- only show the log to the first conflict. When the backjump limit is high+-- enough to allow an exhaustive search, the solver should make use of the final+-- conflict set to only show the conflict between A and F in the summarized log.+testSummarizedLog :: String -> Maybe Int -> String -> TestTree+testSummarizedLog testName mbj expectedMsg =+    runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $+    solverFailure (== expectedMsg)+  where+    db = [+        Right $ exAv "A" 1 [ExAny "B", ExAny "F"]+      , Right $ exAv "B" 3 [ExAny "C"]+      , Right $ exAv "B" 2 [ExAny "D"]+      , Right $ exAv "B" 1 [ExAny "E"]+      , Right $ exAv "E" 1 []+      ]++    goals :: [ExampleVar]+    goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D", "E", "F"]]++dbMinimizeConflictSet :: ExampleDb+dbMinimizeConflictSet = [+    Right $ exAv "A" 3 [ExFix "B" 2, ExFix "C" 1, ExFix "D" 2]+  , Right $ exAv "A" 2 [ExFix "B" 1, ExFix "C" 2, ExFix "D" 2]+  , Right $ exAv "A" 1 [ExFix "B" 1, ExFix "C" 1, ExFix "D" 2]+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 []+  , Right $ exAv "D" 1 []+  ]++-- | Test that the solver can find a minimal conflict set with+-- --minimize-conflict-set. In the first run, the goal order causes the solver+-- to find that A-3 conflicts with B, A-2 conflicts with C, and A-1 conflicts+-- with D. The full log should show that the original final conflict set is+-- {A, B, C, D}. Then the solver should be able to reduce the conflict set to+-- {A, D}, since all versions of A conflict with D. The summarized log should+-- only mention A and D.+testMinimizeConflictSet :: String -> TestTree+testMinimizeConflictSet testName =+    runTest $ minimizeConflictSet $ goalOrder goals $ setVerbose $+    mkTest dbMinimizeConflictSet testName ["A"] $+    SolverResult checkFullLog (Left (== expectedMsg))+  where+    checkFullLog :: [String] -> Bool+    checkFullLog = containsInOrder [+        "[__0] fail (backjumping, conflict set: A, B, C, D)"+      , "Found no solution after exhaustively searching the dependency tree. "+         ++ "Rerunning the dependency solver to minimize the conflict set ({A, B, C, D})."+      , "Trying to remove variable \"A\" from the conflict set."+      , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}."+      , "Trying to remove variable \"B\" from the conflict set."+      , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}."+      , "Trying to remove variable \"D\" from the conflict set."+      , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}."+      ]++    expectedMsg =+        "Could not resolve dependencies:\n"+     ++ "[__0] trying: A-3.0.0 (user goal)\n"+     ++ "[__1] next goal: D (dependency of A)\n"+     ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n"+     ++ "[__1] fail (backjumping, conflict set: A, D)\n"+     ++ "After searching the rest of the dependency tree exhaustively, these "+          ++ "were the goals I've had most trouble fulfilling: A (5), D (4)"++    goals :: [ExampleVar]+    goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]++-- | This test uses the same packages and goal order as testMinimizeConflictSet,+-- but it doesn't set --minimize-conflict-set. The solver should print the+-- original final conflict set and the conflict between A and B. It should also+-- suggest rerunning with --minimize-conflict-set.+testNoMinimizeConflictSet :: String -> TestTree+testNoMinimizeConflictSet testName =+    runTest $ goalOrder goals $ setVerbose $+    mkTest dbMinimizeConflictSet testName ["A"] $+    solverFailure (== expectedMsg)+  where+    expectedMsg =+        "Could not resolve dependencies:\n"+     ++ "[__0] trying: A-3.0.0 (user goal)\n"+     ++ "[__1] next goal: B (dependency of A)\n"+     ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n"+     ++ "[__1] fail (backjumping, conflict set: A, B)\n"+     ++ "After searching the rest of the dependency tree exhaustively, "+          ++ "these were the goals I've had most trouble fulfilling: "+          ++ "A (7), B (2), C (2), D (2)\n"+     ++ "Try running with --minimize-conflict-set to improve the error message."++    goals :: [ExampleVar]+    goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]++{-------------------------------------------------------------------------------+  Simple databases for the illustrations for the backjumping blog post+-------------------------------------------------------------------------------}++-- | Motivate conflict sets+dbBJ1a :: ExampleDb+dbBJ1a = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2]+  , Right $ exAv "B" 1 []+  ]++-- | Show that we can skip some decisions+dbBJ1b :: ExampleDb+dbBJ1b = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Motivate why both A and B need to be in the conflict set+dbBJ1c :: ExampleDb+dbBJ1c = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 []+  ]++-- | Motivate the need for accumulating conflict sets while we walk the tree+dbBJ2 :: ExampleDb+dbBJ2 = [+    Right $ exAv "A"  1 [ExFix "B" 1]+  , Right $ exAv "A"  2 [ExFix "B" 2]+  , Right $ exAv "B"  1 [ExFix "C" 1]+  , Right $ exAv "B"  2 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | Motivate the need for `QGoalReason`+dbBJ3 :: ExampleDb+dbBJ3 = [+    Right $ exAv "A"  1 [ExAny "Ba"]+  , Right $ exAv "A"  2 [ExAny "Bb"]+  , Right $ exAv "Ba" 1 [ExFix "C" 1]+  , Right $ exAv "Bb" 1 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | `QGOalReason` not unique+dbBJ4 :: ExampleDb+dbBJ4 = [+    Right $ exAv "A" 1 [ExAny "B", ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++-- | Flags are represented somewhat strangely in the tree+--+-- This example probably won't be in the blog post itself but as a separate+-- bug report (#3409)+dbBJ5 :: ExampleDb+dbBJ5 = [+    Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]]+  , Right $ exAv "B" 1 [ExFix "D" 1]+  , Right $ exAv "C" 1 [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  ]++-- | Conflict sets for cycles+dbBJ6 :: ExampleDb+dbBJ6 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 [ExAny "C"]+  , Right $ exAv "C" 1 [ExAny "A"]+  ]++-- | Conflicts not unique+dbBJ7 :: ExampleDb+dbBJ7 = [+    Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1]+  , Right $ exAv "B" 1 [ExFix "C" 1]+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Conflict sets for SIR (C shared subgoal of independent goals A, B)+dbBJ8 :: ExampleDb+dbBJ8 = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++{-------------------------------------------------------------------------------+  Databases for build-tool-depends+-------------------------------------------------------------------------------}++-- | Multiple packages depending on exes from 'bt-pkg'.+dbBuildTools :: ExampleDb+dbBuildTools = [+    Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"]+  , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"]+                                          [ExBuildToolAny "bt-pkg" "exe1"]]+  , Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExBuildToolAny "bt-pkg" "exe1"]+  , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"]+  , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"]+  , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"]+                                          [ExAny "unknown"]]+  , Right $ exAv "G" 1 [] `withTest` exTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"]+  , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3]++  , Right $ exAv "bt-pkg" 4 []+  , Right $ exAv "bt-pkg" 3 [] `withExe` exExe "exe2" []+  , Right $ exAv "bt-pkg" 2 [] `withExe` exExe "exe1" []+  , Right $ exAv "bt-pkg" 1 []+  ]++-- The solver should never choose an installed package for a build tool+-- dependency.+rejectInstalledBuildToolPackage :: String -> SolverTest+rejectInstalledBuildToolPackage name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+    "rejecting: A:B:exe.B-1.0.0/installed-1 "+     ++ "(does not contain executable 'exe', which is required by A)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"]+      , Left $ exInst "B" 1 "B-1" []+      ]++-- | This test forces the solver to choose B as a build-tool dependency before+-- it sees the dependency on executable exe2 from B. The solver needs to check+-- that the version that it already chose for B contains the necessary+-- executable. This order causes a different "missing executable" error message+-- than when the solver checks for the executable in the same step that it+-- chooses the build-tool package.+--+-- This case may become impossible if we ever add the executable name to the+-- build-tool goal qualifier. Then this test would involve two qualified goals+-- for B, one for exe1 and another for exe2.+chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest+chooseExeAfterBuildToolsPackage shouldSucceed name =+    goalOrder goals $ mkTest db name ["A"] $+      if shouldSucceed+      then solverSuccess [("A", 1), ("B", 1)]+      else solverFailure $ isInfixOf $+           "rejecting: A:+flagA (requires executable 'exe2' from A:B:exe.B, "+            ++ "but the component does not exist)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1"+                           , exFlagged "flagA" [ExBuildToolAny "B" "exe2"]+                                               [ExAny "unknown"]]+      , Right $ exAv "B" 1 []+         `withExes`+           [exExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]]+      ]++    goals :: [ExampleVar]+    goals = [+        P QualNone "A"+      , P (QualExe "A" "B") "B"+      , F QualNone "A" "flagA"+      ]++-- | Test that when one package depends on two executables from another package,+-- both executables must come from the same instance of that package. We could+-- lift this restriction in the future by adding the executable name to the goal+-- qualifier.+requireConsistentBuildToolVersions :: String -> SolverTest+requireConsistentBuildToolVersions name =+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+        "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n"+     ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1+                           , ExBuildToolFix "B" "exe2" 2 ]+      , Right $ exAv "B" 2 [] `withExes` exes+      , Right $ exAv "B" 1 [] `withExes` exes+      ]++    exes = [exExe "exe1" [], exExe "exe2" []]++-- | This test is similar to the failure case for+-- chooseExeAfterBuildToolsPackage, except that the build tool is unbuildable+-- instead of missing.+chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest+chooseUnbuildableExeAfterBuildToolsPackage name =+    constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $+    goalOrder goals $+    mkTest db name ["A"] $ solverFailure $ isInfixOf $+         "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but "+          ++ "the component is not buildable in the current environment)"+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ ExBuildToolAny "B" "bt1"+                           , exFlagged "use-bt2" [ExBuildToolAny "B" "bt2"]+                                                 [ExAny "unknown"]]+      , Right $ exAvNoLibrary "B" 1+         `withExes`+           [ exExe "bt1" []+           , exExe "bt2" [ExFlagged "build-bt2" (dependencies []) unbuildableDependencies]+           ]+      ]++    goals :: [ExampleVar]+    goals = [+        P QualNone "A"+      , P (QualExe "A" "B") "B"+      , F QualNone "A" "use-bt2"+      ]++{-------------------------------------------------------------------------------+  Databases for legacy build-tools+-------------------------------------------------------------------------------}+dbLegacyBuildTools1 :: ExampleDb+dbLegacyBuildTools1 = [+    Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]+  ]++-- Test that a recognized build tool dependency specifies the name of both the+-- package and the executable. This db has no solution.+dbLegacyBuildTools2 :: ExampleDb+dbLegacyBuildTools2 = [+    Right $ exAv "alex" 1 [] `withExe` exExe "other-exe" [],+    Right $ exAv "other-package" 1 [] `withExe` exExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]+  ]++-- Test that build-tools on a random thing doesn't matter (only+-- the ones we recognize need to be in db)+dbLegacyBuildTools3 :: ExampleDb+dbLegacyBuildTools3 = [+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"]+  ]++-- Test that we can solve for different versions of executables+dbLegacyBuildTools4 :: ExampleDb+dbLegacyBuildTools4 = [+    Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],+    Right $ exAv "alex" 2 [] `withExe` exExe "alex" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1],+    Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2],+    Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+  ]++-- Test that exe is not related to library choices+dbLegacyBuildTools5 :: ExampleDb+dbLegacyBuildTools5 = [+    Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` exExe "alex" [],+    Right $ exAv "A" 1 [],+    Right $ exAv "A" 2 [],+    Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2]+  ]++-- Test that build-tools on build-tools works+dbLegacyBuildTools6 :: ExampleDb+dbLegacyBuildTools6 = [+    Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],+    Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` exExe "happy" [],+    Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"]+  ]++-- Test that build-depends on library/executable package works.+-- Extracted from https://github.com/haskell/cabal/issues/3775+dbIssue3775 :: ExampleDb+dbIssue3775 = [+    Right $ exAv "warp" 1 [],+    -- NB: the warp build-depends refers to the package, not the internal+    -- executable!+    Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` exExe "warp" [ExAny "A"],+    Right $ exAv "B" 2 [ExAny "A", ExAny "warp"]+  ]++-- | Returns true if the second list contains all elements of the first list, in+-- order.+containsInOrder :: Eq a => [a] -> [a] -> Bool+containsInOrder []     _  = True+containsInOrder _      [] = False+containsInOrder (x:xs) (y:ys)+  | x == y = containsInOrder xs ys+  | otherwise = containsInOrder (x:xs) ys
+ tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ParallelListComp #-}+module UnitTests.Distribution.Solver.Modular.WeightedPSQ (+  tests+  ) where++import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Data.List (sort)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (Blind(..), testProperty)++tests :: [TestTree]+tests = [+    testProperty "'toList . fromList' preserves elements" $ \xs ->+        sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs))++  , testProperty "'toList . fromList' sorts stably" $ \xs ->+        let indexAsValue :: [(Int, (), Int)]+            indexAsValue = [(x, (), i) | x <- xs | i <- [0..]]+        in isSorted $ W.toList $ W.fromList indexAsValue++  , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) ->+        isSorted $ W.weights $+        W.mapWeightsWithKey (f :: Int -> Int -> Int) $+        W.fromList (xs :: [(Int, Int, Int)])++  , testCase "applying 'mapWeightsWithKey' twice sorts twice" $+        let indexAsKey :: [((), Int, ())]+            indexAsKey = [((), i, ()) | i <- [0..10]]+            actual = W.toList $+                     W.mapWeightsWithKey (\_ _ -> ()) $+                     W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored+                     W.fromList indexAsKey+        in reverse indexAsKey @?= actual++  , testProperty "'union' sorts by weight" $ \xs ys ->+        isSorted $ W.weights $+        W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)]))++  , testProperty "'union' preserves elements" $ \xs ys ->+        let union = W.union (W.fromList xs)+                            (W.fromList (ys :: [(Int, Int, Int)]))+        in sort (xs ++ ys) == sort (W.toList union)++  , testCase "'lookup' returns first occurrence" $+        let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')]+        in Just 'C' @?= W.lookup True xs+  ]++isSorted :: Ord a => [a] -> Bool+isSorted (x1 : xs@(x2 : _)) = x1 <= x2 && isSorted xs+isSorted _ = True
+ tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module UnitTests.Distribution.Solver.Types.OptionalStanza (+    tests,+) where++import Distribution.Solver.Types.OptionalStanza+import UnitTests.Distribution.Client.ArbitraryInstances ()++import Test.Tasty+import Test.Tasty.QuickCheck++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++tests :: [TestTree]+tests =+    [ testProperty "fromList . toList = id" $ \xs ->+        optStanzaSetFromList (optStanzaSetToList xs) === xs+    , testProperty "member x (insert x xs) = True" $ \x xs ->+        optStanzaSetMember x (optStanzaSetInsert x xs) === True+    , testProperty "member x (singleton y) = (x == y)" $ \x y ->+        optStanzaSetMember x (optStanzaSetSingleton y) === (x == y)+    , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys ->+        optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==>+        optStanzaSetMember x ys++    , testProperty "tabulate index = id" $ \xs ->+        optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int)+    , testProperty "keysFilteredByValue" $ \xs ->+        let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty+        in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas+    ]
+ tests/UnitTests/Options.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveDataTypeable #-}++module UnitTests.Options ( OptionShowSolverLog(..)+                         , OptionMtimeChangeDelay(..)+                         , RunNetworkTests(..)+                         , extraOptions )+       where++import Data.Proxy+import Data.Typeable++import Test.Tasty.Options++{-------------------------------------------------------------------------------+  Test options+-------------------------------------------------------------------------------}++extraOptions :: [OptionDescription]+extraOptions =+  [ Option (Proxy :: Proxy OptionShowSolverLog)+  , Option (Proxy :: Proxy OptionMtimeChangeDelay)+  , Option (Proxy :: Proxy RunNetworkTests)+  ]++newtype OptionShowSolverLog = OptionShowSolverLog Bool+  deriving Typeable++instance IsOption OptionShowSolverLog where+  defaultValue   = OptionShowSolverLog False+  parseValue     = fmap OptionShowSolverLog . safeReadBool+  optionName     = return "show-solver-log"+  optionHelp     = return "Show full log from the solver"+  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)++newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int+  deriving Typeable++instance IsOption OptionMtimeChangeDelay where+  defaultValue   = OptionMtimeChangeDelay 0+  parseValue     = fmap OptionMtimeChangeDelay . safeRead+  optionName     = return "mtime-change-delay"+  optionHelp     = return $ "How long to wait before attempting to detect"+                   ++ "file modification, in microseconds"++newtype RunNetworkTests = RunNetworkTests Bool+  deriving Typeable++instance IsOption RunNetworkTests where+  defaultValue = RunNetworkTests True+  parseValue   = fmap RunNetworkTests . safeReadBool+  optionName   = return "run-network-tests"+  optionHelp   = return "Run tests that need network access (default true)."
+ tests/UnitTests/TempTestDir.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}++module UnitTests.TempTestDir (+    withTestDir, removeDirectoryRecursiveHack+  ) where++import Distribution.Verbosity+import Distribution.Compat.Internal.TempFile (createTempDirectory)+import Distribution.Simple.Utils (warn)++import Control.Monad (when)+import Control.Exception (bracket, try, throwIO)+import Control.Concurrent (threadDelay)++import System.IO.Error+import System.Directory+#if !(MIN_VERSION_directory(1,2,7))+import System.FilePath ((</>))+#endif+import qualified System.Info (os)+++-- | Much like 'withTemporaryDirectory' but with a number of hacks to make+-- sure on windows that we can clean up the directory at the end.+--+withTestDir :: Verbosity -> String ->  (FilePath -> IO a) -> IO a+withTestDir verbosity template action = do+    systmpdir <- getTemporaryDirectory+    bracket+      (createTempDirectory systmpdir template)+      (removeDirectoryRecursiveHack verbosity)+      action+++-- | On Windows, file locks held by programs we run (in this case VCSs)+-- are not always released prior to completing process termination!+-- <https://msdn.microsoft.com/en-us/library/windows/desktop/aa365202.aspx>+-- This means we run into stale locks when trying to delete the test+-- directory. There is no sane way to wait on those locks being released,+-- we just have to wait, try again and hope.+--+-- In addition, on Windows a file that is not writable also cannot be deleted,+-- so we must try setting the permissions to readable before deleting files.+-- Some VCS tools on Windows create files with read-only attributes.+--+removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO ()+removeDirectoryRecursiveHack verbosity dir | isWindows = go 1+  where+    isWindows = System.Info.os == "mingw32"+    limit     = 3++    go :: Int -> IO ()+    go n = do+      res <- try $ removePathForcibly dir+      case res of+        Left e+            -- wait a second and try again+          | isPermissionError e  &&  n < limit -> do+              threadDelay 1000000+              go (n+1)++            -- but if we hit the limt warn and fail.+          | isPermissionError e -> do+              warn verbosity $ "Windows file locking hack: hit the retry limit "+                            ++ show limit ++ " while trying to remove " ++ dir+              throwIO e++            -- or it's a different error fail.+          | otherwise -> throwIO e++        Right () ->+          when (n > 1) $+            warn verbosity $ "Windows file locking hack: had to try "+                          ++ show n ++ " times to remove " ++ dir++removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir+++#if !(MIN_VERSION_directory(1,2,7))+-- A simplified version that ought to work for our use case here, and does+-- not rely on directory internals.+removePathForcibly :: FilePath -> IO ()+removePathForcibly path = do+    makeRemovable path `catchIOError` \ _ -> pure ()+    isDir <- doesDirectoryExist path+    if isDir+       then do+         entries <- getDirectoryContents path+         sequence_+           [ removePathForcibly (path </> entry)+           | entry <- entries, entry /= ".", entry /= ".." ]+         removeDirectory path+       else+         removeFile path+  where+    makeRemovable :: FilePath -> IO ()+    makeRemovable p =+      setPermissions p emptyPermissions {+        readable   = True,+        searchable = True,+        writable   = True+      }+#endif+