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

Author: andreabedini

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

@@ -95,6 +95,8 @@ library
     Distribution.Solver.Types.SolverId
     Distribution.Solver.Types.SolverPackage
     Distribution.Solver.Types.SourcePackage
+    Distribution.Solver.Types.Stage
+    Distribution.Solver.Types.Toolchain
     Distribution.Solver.Types.Variable
 
   build-depends:

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

@@ -0,0 +1,102 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+module Distribution.Solver.Types.Stage
+  ( Stage (..)
+  , Staged (..)
+  , showStage
+  , tabulate
+  , foldMapWithKey
+  , always
+  , prev
+  , next
+  ) where
+
+import Prelude (Enum (..))
+import Distribution.Compat.Prelude
+
+import Data.Maybe (fromJust)
+import GHC.Stack
+
+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, Typeable)
+
+instance Binary Stage
+instance Structured Stage
+
+instance Pretty Stage where
+  pretty = Disp.text . showStage
+
+showStage :: Stage -> String
+showStage Build = "build"
+showStage Host = "host"
+
+-- TOOD: I think there is similar code for stanzas, compare.
+
+newtype Staged a = Staged
+  { getStage :: Stage -> a
+  }
+  deriving (Functor, Generic, Typeable)
+  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
+
+prev :: Stage -> Stage
+prev s | s == minBound = s
+       | otherwise      = Prelude.pred s
+
+next :: Stage -> Stage
+next s | s == maxBound = s
+       | otherwise      = Prelude.succ s

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, Typeable)
+
+-- 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

@@ -64,6 +64,7 @@ import Test.QuickCheck
   )
 import Test.QuickCheck.GenericArbitrary (genericArbitrary)
 import Test.QuickCheck.Instances.Cabal ()
+import Distribution.Solver.Types.Stage (Stage)
 
 -- note: there are plenty of instances defined in ProjectConfig test file.
 -- they should be moved here or into Cabal-quickcheck
@@ -323,6 +324,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
@@ -76,6 +77,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

@@ -48,6 +48,7 @@ import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
   ( ArbitraryOrd (..)
   , testPropertyWithSeed
   )
+import Distribution.Solver.Types.Stage (Stage)
 
 tests :: [TestTree]
 tests =
@@ -588,6 +589,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
@@ -599,6 +606,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)