Move goal qualification types into D.Solver.Types.PackagePath

sebright · sebright · commit 86d8c3333d70 · 2016-06-26T00:31:39.000-07:00
diff --git a/cabal-install/Distribution/Solver/Modular/Assignment.hs b/cabal-install/Distribution/Solver/Modular/Assignment.hs
@@ -22,6 +22,7 @@ import Distribution.PackageDescription (FlagAssignment) -- 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
diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs
@@ -29,6 +29,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
 import Distribution.Solver.Modular.Tree
 
 import Distribution.Solver.Types.ComponentDeps (Component)
+import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings
 
 -- | The state needed during the build phase of the search tree.
@@ -187,4 +188,4 @@ buildTree idx (IndependentGoals ind) igs =
     topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal
 
     qpns | ind       = makeIndependent igs
-         | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
+         | otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs
diff --git a/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs
@@ -14,6 +14,7 @@ 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
diff --git a/cabal-install/Distribution/Solver/Modular/ConflictSet.hs b/cabal-install/Distribution/Solver/Modular/ConflictSet.hs
@@ -37,8 +37,8 @@ import Data.Tree
 import GHC.Stack
 #endif
 
-import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Var
+import Distribution.Solver.Types.PackagePath
 
 -- | The set of variables involved in a solver conflict
 --
diff --git a/cabal-install/Distribution/Solver/Modular/Cycles.hs b/cabal-install/Distribution/Solver/Modular/Cycles.hs
@@ -9,9 +9,9 @@ import qualified Data.Graph as Gr
 import qualified Data.Map   as Map
 
 import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.ConflictSet as CS
+import Distribution.Solver.Types.PackagePath
 
 -- | Find and reject any solutions that are cyclic
 detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason
diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs
@@ -60,6 +60,7 @@ import Distribution.Solver.Modular.Version
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.ComponentDeps (Component(..))
+import Distribution.Solver.Types.PackagePath
 
 #ifdef DEBUG_CONFLICT_SETS
 import GHC.Stack (CallStack)
@@ -213,7 +214,7 @@ data QualifyOptions = QO {
 -- 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 Component PN -> FlaggedDeps Component QPN
-qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
+qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
   where
     go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN
     go = map go1
@@ -236,9 +237,9 @@ qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
     goD (Lang lang)   _    = Lang lang
     goD (Pkg pkn vr)  _    = Pkg pkn vr
     goD (Dep  dep ci) comp
-      | qBase  dep  = Dep (Q (PP ns (Base  pn)) dep) (fmap (Q pp) ci)
-      | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci)
-      | otherwise   = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci)
+      | qBase  dep  = Dep (Q (PackagePath ns (Base  pn)) dep) (fmap (Q pp) ci)
+      | qSetup comp = Dep (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci)
+      | otherwise   = Dep (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) 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
diff --git a/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal-install/Distribution/Solver/Modular/Explore.hs
@@ -10,10 +10,10 @@ import Distribution.Solver.Modular.Assignment
 import Distribution.Solver.Modular.Dependency
 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.Tree
+import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings (EnableBackjumping(..))
 import qualified Distribution.Solver.Types.Progress as P
 
diff --git a/cabal-install/Distribution/Solver/Modular/Flag.hs b/cabal-install/Distribution/Solver/Modular/Flag.hs
@@ -22,6 +22,7 @@ import Distribution.PackageDescription hiding (Flag) -- from Cabal
 
 import Distribution.Solver.Modular.Package
 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 (PI qpn) Flag
diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs
@@ -32,13 +32,14 @@ import qualified Distribution.Solver.Modular.PSQ as P
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.ComponentDeps (Component)
 
 {-------------------------------------------------------------------------------
   Add linking
 -------------------------------------------------------------------------------}
 
-type RelatedGoals = Map (PN, I) [PP]
+type RelatedGoals = Map (PN, I) [PackagePath]
 type Linker       = Reader RelatedGoals
 
 -- | Introduce link nodes into tree tree
@@ -80,7 +81,7 @@ linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption,
 linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
     map aux (M.findWithDefault [] (pn, i) related)
   where
-    aux :: PP -> (POption, Tree QGoalReason)
+    aux :: PackagePath -> (POption, Tree QGoalReason)
     aux pp = (POption i (Just pp), subtree)
 linkChoices _ _ (POption _ (Just _), _) =
     alreadyLinked
@@ -224,7 +225,7 @@ pickConcrete qpn@(Q pp _) i = do
       Just lg ->
         makeCanonical lg qpn i
 
-pickLink :: QPN -> I -> PP -> FlaggedDeps Component QPN -> UpdateState ()
+pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState ()
 pickLink qpn@(Q _pp pn) i pp' deps = do
     vs <- get
 
@@ -246,7 +247,7 @@ pickLink qpn@(Q _pp pn) i pp' deps = do
     -- 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 PP) -> Bool
+    let sanityCheck :: Maybe (PI PackagePath) -> Bool
         sanityCheck Nothing              = False
         sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI
     assert (sanityCheck (lgCanon lgTarget)) $ return ()
@@ -476,10 +477,10 @@ data LinkGroup = LinkGroup {
       --
       -- We may not know this yet (if we are constructing link groups
       -- for dependencies)
-    , lgCanon :: Maybe (PI PP)
+    , lgCanon :: Maybe (PI PackagePath)
 
       -- | The members of the link group
-    , lgMembers :: Set PP
+    , 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
@@ -509,19 +510,19 @@ showLinkGroup :: LinkGroup -> String
 showLinkGroup lg =
     "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
   where
-    showMember :: PP -> String
+    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 :: PP -> QPN
+    qpn :: PackagePath -> QPN
     qpn pp = Q pp (lgPackage lg)
 
 -- | Creates a link group that contains a single member.
-lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup
+lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
 lgSingleton (Q pp pn) canon = LinkGroup {
       lgPackage = pn
     , lgCanon   = canon
diff --git a/cabal-install/Distribution/Solver/Modular/Log.hs b/cabal-install/Distribution/Solver/Modular/Log.hs
@@ -11,11 +11,11 @@ import Control.Applicative
 import Data.List as L
 import Data.Maybe (isNothing)
 
+import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
 
 import Distribution.Solver.Modular.Dependency
 import Distribution.Solver.Modular.Message
-import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree (FailReason(..))
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 
diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs
@@ -16,6 +16,7 @@ import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
          ( FailReason(..), POption(..) )
 import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
 
 data Message =
diff --git a/cabal-install/Distribution/Solver/Modular/Package.hs b/cabal-install/Distribution/Solver/Modular/Package.hs
@@ -7,28 +7,22 @@ module Distribution.Solver.Modular.Package
   , PackageName(..)
   , PI(..)
   , PN
-  , PP(..)
-  , Namespace(..)
-  , Qualifier(..)
-  , QPN
   , QPV
-  , Q(..)
   , instI
   , makeIndependent
   , primaryPP
   , showI
   , showPI
   , showQPN
-  , showPP
   , unPN
   ) where
 
 import Data.List as L
 
 import Distribution.Package -- from Cabal
-import Distribution.Text    -- from Cabal
 
 import Distribution.Solver.Modular.Version
+import Distribution.Solver.Types.PackagePath
 
 -- | A package name.
 type PN = PackageName
@@ -41,7 +35,7 @@ unPN (PackageName pn) = pn
 type PV = PackageId
 
 -- | Qualified package version.
-type QPV = Q PV
+type QPV = Qualified PV
 
 -- | Package id. Currently just a black-box string.
 type PId = UnitId
@@ -83,94 +77,19 @@ instI :: I -> Bool
 instI (I _ (Inst _)) = True
 instI _              = False
 
--- | A package path consists of a namespace and a package path inside that
--- namespace.
-data PP = PP 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
-
-    -- | Independent namespace
-    --
-    -- For now we just number these (rather than giving them more structure).
-  | Independent Int
-  deriving (Eq, Ord, Show)
-
--- | Qualifier of a package within a namespace (see 'PP')
-data Qualifier =
-    -- | Top-level dependency in this namespace
-    Unqualified
-
-    -- | Any dependency on base is considered independent
-    --
-    -- This makes it possible to have base shims.
-  | Base PN
-
-    -- | 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).
-  | Setup PN
-  deriving (Eq, Ord, Show)
-
 -- | Is the package in the primary group of packages. In particular this
 -- does not include packages pulled in as setup deps.
 --
-primaryPP :: PP -> Bool
-primaryPP (PP _ns q) = go q
+primaryPP :: PackagePath -> Bool
+primaryPP (PackagePath _ns q) = go q
   where
     go Unqualified = True
     go (Base  _)   = True
     go (Setup _)   = False
 
--- | String representation of a package path.
---
--- NOTE: The result of 'showPP' is either empty or results in a period, so that
--- it can be prepended to a package name.
-showPP :: PP -> String
-showPP (PP ns q) =
-    case ns of
-      DefaultNamespace -> go q
-      Independent i    -> show i ++ "." ++ go q
-  where
-    -- Print the qualifier
-    --
-    -- 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@).
-    go Unqualified = ""
-    go (Setup pn)  = display pn ++ "-setup."
-    go (Base  pn)  = display pn ++ "."
-
--- | A qualified entity. Pairs a package path with the entity.
-data Q a = Q PP a
-  deriving (Eq, Ord, Show)
-
--- | Standard string representation of a qualified entity.
-showQ :: (a -> String) -> (Q a -> String)
-showQ showa (Q pp x) = showPP pp ++ showa x
-
--- | Qualified package name.
-type QPN = Q PN
-
--- | String representation of a qualified package path.
-showQPN :: QPN -> String
-showQPN = showQ display
-
 -- | Create artificial parents for each of the package names, making
 -- them all independent.
 makeIndependent :: [PN] -> [QPN]
 makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
-                               , let pp = PP (Independent i) Unqualified
+                               , let pp = PackagePath (Independent i) Unqualified
                      ]
diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs
@@ -33,6 +33,7 @@ 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.Modular.Dependency
@@ -126,7 +127,7 @@ preferPackageStanzaPreferences pcs = trav go
 -- 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 :: PP
+processPackageConstraintP :: PackagePath
                           -> ConflictSet QPN
                           -> I
                           -> LabeledPackageConstraint
@@ -309,7 +310,7 @@ deferSetupChoices = trav go
     go x                = x
 
     noSetup :: Goal QPN -> Bool
-    noSetup (Goal (P (Q (PP _ns (Setup _)) _)) _) = False
+    noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False
     noSetup _                                     = True
 
 -- | Transformation that tries to avoid making weak flag choices early.
diff --git a/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal-install/Distribution/Solver/Modular/Solver.hs
@@ -14,6 +14,7 @@ import Data.Version
 
 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
@@ -206,5 +207,5 @@ _removeGR = trav go
 
    dummy :: QGoalReason
    dummy = PDependency
-         $ PI (Q (PP DefaultNamespace Unqualified) (PackageName "$"))
+         $ PI (Q (PackagePath DefaultNamespace Unqualified) (PackageName "$"))
               (I (Version [1] []) InRepo)
diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs
@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.PSQ (PSQ)
 import qualified Distribution.Solver.Modular.PSQ as P
 import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.PackagePath
 
 -- | Type of the search tree. Inlining the choice nodes for now.
 data Tree a =
@@ -90,7 +91,7 @@ data Tree a =
 -- 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 PP)
+data POption = POption I (Maybe PackagePath)
   deriving (Eq, Show)
 
 data FailReason = InconsistentInitialConstraints
diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs
diff --git a/cabal-install/Distribution/Solver/Modular/Var.hs b/cabal-install/Distribution/Solver/Modular/Var.hs
diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
