From a7ca91b1de004739774dfdcdf5529d112c2cafc5 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 1 Jun 2015 10:10:00 +0100
Subject: [PATCH] Introduce and use innM.
Addresses https://github.com/haskell/cabal/pull/2500#commitcomment-10797523.
---
.../Client/Dependency/Modular/Preference.hs | 11 +++--------
.../Distribution/Client/Dependency/Modular/Tree.hs | 12 ++++++++++--
2 files changed, 13 insertions(+), 10 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 0834f0a5a0..6b6ca343df 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -331,16 +331,11 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
where
go :: TreeF QGoalReasonChain (EnforceSIR (Tree QGoalReasonChain)) -> EnforceSIR (Tree QGoalReasonChain)
- -- We just verify package choices
+ -- We just verify package choices.
go (PChoiceF qpn gr cs) =
PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)
-
- -- For all other nodes we don't check anything
- go (FChoiceF qfn gr t m cs) = FChoice qfn gr t m <$> sequence cs
- go (SChoiceF qsn gr t cs) = SChoice qsn gr t <$> sequence cs
- go (GoalChoiceF cs) = GoalChoice <$> sequence cs
- go (DoneF revDepMap) = return $ Done revDepMap
- go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+ go _otherwise =
+ innM _otherwise
-- The check proper
goP :: QPN -> POption -> EnforceSIR (Tree QGoalReasonChain) -> EnforceSIR (Tree QGoalReasonChain)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index f9e03cbb02..01ba37a678 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Distribution.Client.Dependency.Modular.Tree where
-import Control.Monad hiding (mapM)
+import Control.Monad hiding (mapM, sequence)
import Data.Foldable
import Data.Traversable
-import Prelude hiding (foldr, mapM)
+import Prelude hiding (foldr, mapM, sequence)
import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
@@ -95,6 +95,14 @@ inn (GoalChoiceF ts) = GoalChoice ts
inn (DoneF x ) = Done x
inn (FailF c x ) = Fail c x
+innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)
+innM (PChoiceF p i ts) = liftM (PChoice p i ) (sequence ts)
+innM (FChoiceF p i b m ts) = liftM (FChoice p i b m) (sequence ts)
+innM (SChoiceF p i b ts) = liftM (SChoice p i b ) (sequence ts)
+innM (GoalChoiceF ts) = liftM (GoalChoice ) (sequence ts)
+innM (DoneF x ) = return $ Done x
+innM (FailF c x ) = return $ Fail c x
+
-- | Determines whether a tree is active, i.e., isn't a failure node.
active :: Tree a -> Bool
active (Fail _ _) = False
--
GitLab