feat(cabal-install-solver): introduce Stage and Toolchain

add stages list

Author: andreabedini

cabal-install-solver/cabal-install-solver.cabal

@@ -95,7 +95,9 @@ library
     Distribution.Solver.Types.SolverId
     Distribution.Solver.Types.SolverPackage
     Distribution.Solver.Types.SourcePackage
+    Distribution.Solver.Types.Stage
     Distribution.Solver.Types.SummarizedMessage
+    Distribution.Solver.Types.Toolchain
     Distribution.Solver.Types.Variable
 
   build-depends:

cabal-install-solver/src/Distribution/Solver/Types/Stage.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+module Distribution.Solver.Types.Stage
+  ( Stage (..)
+  , showStage
+  , stages
+  , prevStage
+  , nextStage
+  , Staged (..)
+  , tabulate
+  , foldMapWithKey
+  , always
+  ) where
+
+import Prelude (Enum (..))
+import Distribution.Compat.Prelude
+import qualified Distribution.Compat.CharParsing as P
+
+import Data.Maybe (fromJust)
+import GHC.Stack
+
+import Distribution.Parsec (Parsec (..))
+import Distribution.Pretty (Pretty (..))
+import Distribution.Utils.Structured (Structured (..))
+import qualified Text.PrettyPrint as Disp
+
+
+data Stage
+  = -- | -- The system where the build is running
+    Build
+  | -- | -- The system where the built artifacts will run
+    Host
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+
+instance Binary Stage
+instance Structured Stage
+
+instance Pretty Stage where
+  pretty = Disp.text . showStage
+
+showStage :: Stage -> String
+showStage Build = "build"
+showStage Host = "host"
+
+instance Parsec Stage where
+  parsec = P.choice [
+      Build <$ P.string "build",
+      Host <$ P.string "host"
+    ]
+
+stages :: [Stage]
+stages = [minBound .. maxBound]
+
+prevStage :: Stage -> Stage
+prevStage s | s == minBound = s
+            | otherwise     = Prelude.pred s 
+nextStage :: Stage -> Stage
+nextStage s | s == maxBound = s
+            | otherwise     = Prelude.succ s
+
+-- TOOD: I think there is similar code for stanzas, compare.
+
+newtype Staged a = Staged
+  { getStage :: Stage -> a
+  }
+  deriving (Functor, Generic)
+  deriving Applicative via ((->) Stage)
+
+instance Eq a => Eq (Staged a) where
+  lhs == rhs =
+    all
+      (\stage -> getStage lhs stage == getStage rhs stage)
+      [minBound .. maxBound]
+
+instance Show a => Show (Staged a) where
+  showsPrec _ staged =
+    showList
+      [ (stage, getStage staged stage)
+      | stage <- [minBound .. maxBound]
+      ]
+
+instance Foldable Staged where
+  foldMap f (Staged gs) = foldMap (f . gs) [minBound..maxBound]
+
+instance Traversable Staged where
+  traverse f = fmap index . traverse (traverse f) . tabulate
+
+instance Binary a => Binary (Staged a) where
+  put staged = put (tabulate staged)
+  -- TODO this could be done better I think
+  get =  index <$> get
+
+-- TODO: I have no idea if this is right
+instance (Typeable a, Structured a) => Structured (Staged a) where
+  structure _ = structure (Proxy :: Proxy [(Stage, a)])
+
+tabulate :: Staged a -> [(Stage, a)]
+tabulate staged =
+  [ (stage, getStage staged stage)
+  | stage <- [minBound .. maxBound]
+  ]
+
+index :: HasCallStack => [(Stage, a)] -> Staged a
+index t = Staged (\s -> fromJust (lookup s t))
+
+foldMapWithKey :: Monoid m => (Stage -> a -> m) -> Staged a -> m
+foldMapWithKey f = foldMap (uncurry f) . tabulate
+
+always :: a -> Staged a
+always = Staged . const

cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Solver.Types.Toolchain
+  ( Toolchain (..)
+  , Toolchains
+  , Stage (..)
+  , Staged (..)
+  ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Simple.Compiler
+import Distribution.Simple.Program.Db
+import Distribution.Solver.Types.Stage (getStage, Stage (..), Staged (..))
+import Distribution.System
+
+---------------------------
+-- Toolchain
+--
+
+data Toolchain = Toolchain
+  { toolchainPlatform :: Platform
+  , toolchainCompiler :: Compiler
+  , toolchainProgramDb :: ProgramDb
+  }
+  deriving (Show, Generic)
+
+-- TODO: review this
+instance Eq Toolchain where
+  lhs == rhs =
+    (((==) `on` toolchainPlatform) lhs rhs)
+      && (((==) `on` toolchainCompiler) lhs rhs)
+      && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs)
+
+instance Binary Toolchain
+instance Structured Toolchain
+
+type Toolchains = Staged Toolchain

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -44,6 +44,7 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalSt
 import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
 
 import Data.Coerce (Coercible, coerce)
+import Distribution.Solver.Types.Stage (Stage)
 import Network.URI (URI (..), URIAuth (..), isUnreserved)
 import Test.QuickCheck
   ( Arbitrary (..)
@@ -324,6 +325,10 @@ instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where
       TestStanzas -> x1
       BenchStanzas -> x2
 
+instance Arbitrary Stage where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 -------------------------------------------------------------------------------
 -- BuildReport
 -------------------------------------------------------------------------------

cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs

@@ -9,6 +9,7 @@ import Distribution.Solver.Types.OptionalStanza
 import Distribution.Solver.Types.PackageConstraint
 import Distribution.Solver.Types.ProjectConfigPath
 import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Stage
 
 import Distribution.Client.BuildReports.Types
 import Distribution.Client.CmdInstall.ClientInstallFlags
@@ -73,6 +74,7 @@ instance ToExpr ReorderGoals
 instance ToExpr RepoIndexState
 instance ToExpr RepoName
 instance ToExpr ReportLevel
+instance ToExpr Stage
 instance ToExpr StrongFlags
 instance ToExpr Timestamp
 instance ToExpr TotalIndexState

cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs

@@ -43,6 +43,7 @@ import Distribution.Solver.Types.Variable
 import Distribution.Verbosity
 import Distribution.Version
 
+import Distribution.Solver.Types.Stage (Stage)
 import UnitTests.Distribution.Solver.Modular.DSL
 import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
   ( ArbitraryOrd (..)
@@ -586,6 +587,12 @@ instance Arbitrary OptionalStanza where
   shrink BenchStanzas = [TestStanzas]
   shrink TestStanzas = []
 
+instance Arbitrary Stage where
+  arbitrary = elements [minBound .. maxBound]
+
+  shrink stage =
+    [stage' | stage' <- [minBound .. maxBound], stage' /= stage]
+
 instance ArbitraryOrd pn => ArbitraryOrd (Variable pn)
 instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a)
 instance ArbitraryOrd P.PackagePath
@@ -597,6 +604,7 @@ instance ArbitraryOrd ShortText where
   arbitraryCompare = do
     strc <- arbitraryCompare
     pure $ \l r -> strc (fromShortText l) (fromShortText r)
+instance ArbitraryOrd Stage
 
 deriving instance Generic (Variable pn)
 deriving instance Generic (P.Qualified a)