feat(cabal-install): all of it

Author: andreabedini

cabal-install/cabal-install.cabal

@@ -193,6 +193,7 @@ library
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning
         Distribution.Client.ProjectPlanning.SetupPolicy
+        Distribution.Client.ProjectPlanning.Stage
         Distribution.Client.ProjectPlanning.Types
         Distribution.Client.RebuildMonad
         Distribution.Client.Reconfigure

cabal-install/src/Distribution/Client/CmdExec.hs

@@ -1,6 +1,9 @@
 -------------------------------------------------------------------------------
 -------------------------------------------------------------------------------
 {-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 -- |
 -- Module      :  Distribution.Client.Exec
@@ -56,7 +59,8 @@ import Distribution.Client.ProjectPlanning
   )
 import qualified Distribution.Client.ProjectPlanning as Planning
 import Distribution.Client.ProjectPlanning.Types
-  ( dataDirsEnvironmentForPlan
+  ( Toolchain (..)
+  , dataDirsEnvironmentForPlan
   )
 import Distribution.Client.Setup
   ( GlobalFlags
@@ -104,6 +108,7 @@ import Prelude ()
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Distribution.Client.Errors
+import Distribution.Solver.Types.Stage
 
 execCommand :: CommandUI (NixStyleFlags ())
 execCommand =
@@ -152,6 +157,12 @@ execAction flags extraArgs globalFlags = do
       baseCtx
       (\plan -> return (plan, M.empty))
 
+  let toolchains = pkgConfigToolchains (elaboratedShared buildCtx)
+      -- We need the compiler and platform to set up the environment.
+      compilers = toolchainCompiler <$> toolchains
+      platforms = toolchainPlatform <$> toolchains
+      progdbs = toolchainProgramDb <$> toolchains
+
   -- We use the build status below to decide what libraries to include in the
   -- compiler environment, but we don't want to actually build anything. So we
   -- pass mempty to indicate that nothing happened and we just want the current
@@ -166,7 +177,9 @@ execAction flags extraArgs globalFlags = do
 
   -- Some dependencies may have executables. Let's put those on the PATH.
   let extraPaths = pathAdditions baseCtx buildCtx
-      pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx)
+      -- NOTE: only build-stage dependencies make sense here
+      pkgProgs = getStage progdbs Build
+      --
       extraEnvVars =
         dataDirsEnvironmentForPlan
           (distDirLayout baseCtx)
@@ -181,7 +194,8 @@ execAction flags extraArgs globalFlags = do
   -- point at the file.
   -- In case ghc is too old to support environment files,
   -- we pass the same info as arguments
-  let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
+  -- FIXME
+  let compiler = getStage compilers Host
       envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)
   case extraArgs of
     [] -> dieWithException verbosity SpecifyAnExecutable
@@ -234,7 +248,9 @@ matchCompilerPath elaboratedShared program =
   programPath program
     `elem` (programPath <$> configuredCompilers)
   where
-    configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared
+    progdbs = toolchainProgramDb <$> pkgConfigToolchains elaboratedShared
+    -- FIXME
+    configuredCompilers = configuredPrograms (getStage progdbs Host)
 
 -- | Execute an action with a temporary .ghc.environment file reflecting the
 -- current environment. The action takes an environment containing the env

cabal-install/src/Distribution/Client/CmdGenBounds.hs

@@ -18,7 +18,6 @@ import Control.Monad (mapM_)
 import Distribution.Client.Errors
 
 import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets)
-import Distribution.Client.ProjectPlanning.Types
 import Distribution.Client.Types.ConfiguredId (confInstId)
 import Distribution.Client.Utils hiding (pvpize)
 import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId)

cabal-install/src/Distribution/Client/CmdHaddock.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -29,8 +30,12 @@ import Distribution.Client.ProjectConfig.Types
   , ProjectConfig (..)
   )
 import Distribution.Client.ProjectOrchestration
-import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
   ( ElaboratedSharedConfig (..)
+  , Stage (..)
+  , Staged (..)
+  , Toolchain (..)
+  , getStage
   )
 import Distribution.Client.Setup
   ( GlobalFlags
@@ -160,6 +165,7 @@ haddockAction relFlags targetStrings globalFlags = do
             projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}}
         | otherwise =
             projCtx
+
   absProjectConfig <- mkConfigAbsolute relProjectConfig
   let baseCtx = relBaseCtx{projectConfig = absProjectConfig}
 
@@ -192,6 +198,9 @@ haddockAction relFlags targetStrings globalFlags = do
 
   printPlan verbosity baseCtx buildCtx
 
+  let toolchains = pkgConfigToolchains (elaboratedShared buildCtx)
+
+  -- TODO
   progs <-
     reconfigurePrograms
       verbosity
@@ -200,14 +209,19 @@ haddockAction relFlags targetStrings globalFlags = do
       -- we need to insert 'haddockProgram' before we reconfigure it,
       -- otherwise 'set
       . addKnownProgram haddockProgram
-      . pkgConfigCompilerProgs
-      . elaboratedShared
-      $ buildCtx
+      -- TODO
+      . toolchainProgramDb
+      $ getStage toolchains Host
+
+  let toolchains' = Staged $ \case
+        Host -> (getStage toolchains' Host){toolchainProgramDb = progs}
+        Build -> getStage toolchains' Build
+
   let buildCtx' =
         buildCtx
           { elaboratedShared =
               (elaboratedShared buildCtx)
-                { pkgConfigCompilerProgs = progs
+                { pkgConfigToolchains = toolchains'
                 }
           }
 

cabal-install/src/Distribution/Client/CmdHaddockProject.hs

@@ -39,7 +39,9 @@ import Distribution.Client.ProjectPlanning
   , TargetAction (..)
   )
 import Distribution.Client.ProjectPlanning.Types
-  ( elabDistDirParams
+  ( Toolchain (..)
+  , elabDistDirParams
+  , getStage
   )
 import Distribution.Client.ScriptUtils
   ( AcceptNoTargets (..)
@@ -71,18 +73,11 @@ import Distribution.Simple.Flag
   , pattern Flag
   , pattern NoFlag
   )
-import Distribution.Simple.Haddock (createHaddockIndex)
+
+-- import Distribution.Simple.Haddock (createHaddockIndex)
 import Distribution.Simple.InstallDirs
   ( toPathTemplate
   )
-import Distribution.Simple.Program.Builtin
-  ( haddockProgram
-  )
-import Distribution.Simple.Program.Db
-  ( addKnownProgram
-  , reconfigurePrograms
-  , requireProgramVersion
-  )
 import Distribution.Simple.Setup
   ( HaddockFlags (..)
   , HaddockProjectFlags (..)
@@ -103,8 +98,6 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su
 import Distribution.Types.PackageId (pkgName)
 import Distribution.Types.PackageName (unPackageName)
 import Distribution.Types.UnitId (unUnitId)
-import Distribution.Types.Version (mkVersion)
-import Distribution.Types.VersionRange (orLaterVersion)
 import Distribution.Verbosity as Verbosity
   ( normal
   )
@@ -170,24 +163,26 @@ haddockProjectAction flags _extraArgs globalFlags = do
           pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
           pkgs = matchingPackages elaboratedPlan
 
-      progs <-
-        reconfigurePrograms
-          verbosity
-          (haddockProjectProgramPaths flags)
-          (haddockProjectProgramArgs flags)
-          -- we need to insert 'haddockProgram' before we reconfigure it,
-          -- otherwise 'set
-          . addKnownProgram haddockProgram
-          . pkgConfigCompilerProgs
-          $ sharedConfig
-      let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
-
-      _ <-
-        requireProgramVersion
-          verbosity
-          haddockProgram
-          (orLaterVersion (mkVersion [2, 26, 1]))
-          progs
+      -- TODO
+      -- progs <-
+      --   reconfigurePrograms
+      --     verbosity
+      --     (haddockProjectProgramPaths flags)
+      --     (haddockProjectProgramArgs flags)
+      --     -- we need to insert 'haddockProgram' before we reconfigure it,
+      --     -- otherwise 'set
+      --     . addKnownProgram haddockProgram
+      --     . pkgConfigCompilerProgs
+      --     $ sharedConfig
+      -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
+      let sharedConfig' = sharedConfig
+
+      -- _ <-
+      --   requireProgramVersion
+      --     verbosity
+      --     haddockProgram
+      --     (orLaterVersion (mkVersion [2, 26, 1]))
+      --     progs
 
       --
       -- Build project; we need to build dependencies.
@@ -302,10 +297,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
               False -> do
                 let pkg_descr = elabPkgDescription package
                     unitId = unUnitId (elabUnitId package)
+                    compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig'
+                    compiler = getStage compilers (elabStage package)
                     packageDir =
                       storePackageDirectory
                         (cabalStoreDirLayout cabalLayout)
-                        (pkgConfigCompiler sharedConfig')
+                        compiler
                         (elabUnitId package)
                     -- TODO: use `InstallDirTemplates`
                     docDir = packageDir </> "share" </> "doc" </> "html"
@@ -325,7 +322,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
       -- generate index, content, etc.
       --
 
-      let (missingHaddocks, packageInfos') = partitionEithers packageInfos
+      let (missingHaddocks, _packageInfos') = partitionEithers packageInfos
       when (not (null missingHaddocks)) $ do
         warn verbosity "missing haddocks for some packages from the store"
         -- Show the package list if `-v1` is passed; it's usually a long list.
@@ -334,28 +331,31 @@ haddockProjectAction flags _extraArgs globalFlags = do
         -- `documentation: True` in the global config).
         info verbosity (intercalate "\n" missingHaddocks)
 
-      let flags' =
-            flags
-              { haddockProjectDir = Flag outputDir
-              , haddockProjectInterfaces =
-                  Flag
-                    [ ( interfacePath
-                      , Just url
-                      , Just url
-                      , visibility
-                      )
-                    | (url, interfacePath, visibility) <- packageInfos'
-                    ]
-              , haddockProjectUseUnicode = NoFlag
-              }
-      createHaddockIndex
-        verbosity
-        (pkgConfigCompilerProgs sharedConfig')
-        (pkgConfigCompiler sharedConfig')
-        (pkgConfigPlatform sharedConfig')
-        Nothing
-        flags'
+      warn verbosity "createHaddockIndex not implemented"
   where
+    -- let flags' =
+    --       flags
+    --         { haddockProjectDir = Flag outputDir
+    --         , haddockProjectInterfaces =
+    --             Flag
+    --               [ ( interfacePath
+    --                 , Just url
+    --                 , Just url
+    --                 , visibility
+    --                 )
+    --               | (url, interfacePath, visibility) <- packageInfos'
+    --               ]
+    --         , haddockProjectUseUnicode = NoFlag
+    --         }
+    -- -- NOTE: this lives in Cabal
+    -- createHaddockIndex
+    --   verbosity
+    --   (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig')
+    --   (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig')
+    --   (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig')
+    --   Nothing
+    --   flags'
+
     -- build all packages with appropriate haddock flags
     commonFlags = haddockProjectCommonFlags flags
 

cabal-install/src/Distribution/Client/CmdListBin.hs

@@ -48,7 +48,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..))
 import Distribution.Simple.BuildPaths (dllExtension, exeExtension)
 import Distribution.Simple.Command (CommandUI (..))
 import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText)
-import Distribution.System (Platform)
 import Distribution.Types.ComponentName (showComponentName)
 import Distribution.Types.UnitId (UnitId)
 import Distribution.Types.UnqualComponentName (UnqualComponentName)
@@ -204,8 +203,8 @@ listbinAction flags args globalFlags = do
             | s == selectedComponent -> [flib_file' s]
           _ -> []
 
-        plat :: Platform
-        plat = pkgConfigPlatform elaboratedSharedConfig
+        Toolchain{toolchainPlatform = plat} =
+          getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab)
 
         -- here and in PlanOutput,
         -- use binDirectoryFor?

cabal-install/src/Distribution/Client/CmdPath.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- |
 -- Module      :  Distribution.Client.CmdPath
@@ -41,14 +42,12 @@ import Distribution.Client.ProjectConfig.Types
   )
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types (Toolchain (..))
 import Distribution.Client.RebuildMonad (runRebuild)
 import Distribution.Client.ScriptUtils
 import Distribution.Client.Setup
   ( yesNoOpt
   )
-import Distribution.Client.Toolchain
-  ( Toolchain (..)
-  )
 import Distribution.Client.Utils.Json
   ( (.=)
   )
@@ -79,9 +78,11 @@ import Distribution.Simple.Program
 import Distribution.Simple.Utils
   ( die'
   , dieWithException
+  , warn
   , withOutputMarker
   , wrapText
   )
+import Distribution.Solver.Types.Stage
 import Distribution.Verbosity
   ( normal
   )
@@ -247,10 +248,13 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF
     if not $ fromFlagOrDefault False (pathCompiler pathFlags)
       then pure Nothing
       else do
-        toolchain <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
-        compilerProg <- requireCompilerProg verbosity (toolchainCompiler toolchain)
-        (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb toolchain)
-        pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler toolchain)
+        let projectRoot = distProjectRootDirectory (distDirLayout baseCtx)
+        toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
+        warn verbosity "WIP: Assuming host toolchain, result might be wrong"
+        let Toolchain{..} = getStage toolchains Host
+        compilerProg <- requireCompilerProg verbosity toolchainCompiler
+        (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb
+        pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler
 
   paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do
     t <- getPathLocation baseCtx p