diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000000..bd23b025d1 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,4 @@ +cradle: + stack: + - path: "." + component: "stack:lib" \ No newline at end of file diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index afa51c4d4a..f3cbafba7f 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -43,6 +43,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent +import Stack.Types.PackageComponent (libraryPackage) import Stack.Types.Package import Stack.Types.SourceMap import Stack.Types.Version @@ -90,26 +91,30 @@ data AddDepRes type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)]) -data W = W - { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) - , wInstall :: !(Map Text InstallLocation) +data PlanDraft = PlanDraft + { pdFinals :: !(Map PackageName (Either ConstructPlanException Task)) + , pdInstall :: !(Map Text InstallLocation) -- ^ executable to be installed, and location where the binary is placed - , wDirty :: !(Map PackageName Text) + , pdDirty :: !(Map PackageName Text) -- ^ why a local package is considered dirty - , wWarnings :: !([Text] -> [Text]) + , pdWarning :: !([Text] -> [Text]) -- ^ Warnings - , wParents :: !ParentMap + , pdParents :: !ParentMap -- ^ Which packages a given package depends on, along with the package's version } deriving Generic -instance Semigroup W where +instance Semigroup PlanDraft where (<>) = mappenddefault -instance Monoid W where +instance Monoid PlanDraft where mempty = memptydefault mappend = (<>) +-- | A monad transformer reading an environment of type 'Ctx', +-- collecting an output of type 'PlanDraft' and updating a state of type +-- '(Map PackageName (Either ConstructPlanException AddDepRes))' to an inner monad 'IO'. +-- The R stands for read, W for write and S for state. type M = RWST -- TODO replace with more efficient WS stack on top of StackT Ctx - W + PlanDraft (Map PackageName (Either ConstructPlanException AddDepRes)) IO @@ -188,7 +193,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap let inner = mapM_ onTarget $ Map.keys (smtTargets $ smTargets sourceMap) pathEnvVar' <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH" let ctx = mkCtx econfig globalCabalVersion sources mcur pathEnvVar' - ((), m, W efinals installExes dirtyReason warnings parents) <- + ((), m, PlanDraft efinals installExes dirtyReason warnings parents) <- liftIO $ runRWST inner ctx M.empty mapM_ (logWarn . RIO.display) (warnings []) let toEither (_, Left e) = Left e @@ -200,7 +205,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap then do let toTask (_, ADRFound _ _) = Nothing toTask (name, ADRToInstall task) = Just (name, task) - tasks = M.fromList $ mapMaybe toTask adrs + tasks = first libraryPackage $ M.fromList $ mapMaybe toTask adrs takeSubset = case boptsCLIBuildSubset $ bcoBuildOptsCLI baseConfigOpts0 of BSAll -> pure @@ -412,7 +417,7 @@ addFinal lp package isAllInOne buildHaddocks = do , taskAnyMissing = not $ Set.null missing , taskBuildTypeConfig = packageBuildTypeConfig package } - tell mempty { wFinals = Map.singleton (packageName package) res } + tell mempty { pdFinals = Map.singleton (packageName package) res } -- | Given a 'PackageName', adds all of the build tasks to build the -- package, if needed. @@ -513,7 +518,7 @@ tellExecutablesPackage loc p = do | otherwise = Set.empty goSource PSRemote{} = Set.empty - tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } + tell mempty { pdInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where filterComps myComps x | Set.null myComps = x @@ -618,7 +623,7 @@ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled (missing, return $ if shouldInstall then Nothing else Just installed (Just _, False) -> do let t = T.intercalate ", " $ map (T.pack . packageNameString . pkgName) (Set.toList missing) - tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } + tell mempty { pdDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } return Nothing (Nothing, _) -> return Nothing let loc = psLocation ps @@ -716,7 +721,7 @@ addPackageDeps package = do then return True else do let warn_ reason = - tell mempty { wWarnings = (msg:) } + tell mempty { pdWarning = (msg:) } where msg = T.concat [ "WARNING: Ignoring " @@ -771,7 +776,7 @@ addPackageDeps package = do adrVersion (ADRFound _ installed) = installedVersion installed -- Update the parents map, for later use in plan construction errors -- - see 'getShortestDepsPath'. - addParent depname range mversion = tell mempty { wParents = MonoidMap $ M.singleton depname val } + addParent depname range mversion = tell mempty { pdParents = MonoidMap $ M.singleton depname val } where val = (First mversion, [(packageIdentifier package, range)]) @@ -837,7 +842,7 @@ checkDirtiness ps installed package present buildHaddocks = do case mreason of Nothing -> return False Just reason -> do - tell mempty { wDirty = Map.singleton (packageName package) reason } + tell mempty { pdDirty = Map.singleton (packageName package) reason } return True describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text @@ -935,7 +940,7 @@ packageDepsWithTools p = do case mfound of Left _ -> return $ Just $ ToolWarning name (packageName p) Right _ -> return Nothing - tell mempty { wWarnings = (map toolWarningText warnings ++) } + tell mempty { pdWarning = (map toolWarningText warnings ++) } return $ packageDeps p -- | Warn about tools in the snapshot definition. States the tool name diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 0b11497283..7fce4580f5 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -82,6 +82,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent +import Stack.Types.PackageComponent (forgetComponentName, PackageComponentName, getPackageNameLength) import Stack.Types.Package import Stack.Types.Version import qualified System.Directory as D @@ -500,7 +501,7 @@ executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages local where mlargestPackageName = Set.lookupMax $ - Set.map (length . packageNameString) $ + Set.map getPackageNameLength $ Map.keysSet (planTasks plan) <> Map.keysSet (planFinals plan) copyExecutables @@ -647,7 +648,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (boptsOpenHaddocks eeBuildOpts) $ do let planPkgs, localPkgs, installedPkgs, availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation) - planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan) + planPkgs = Map.mapKeys forgetComponentName $ Map.map (taskProvides &&& taskLocation) (planTasks plan) localPkgs = Map.fromList [(packageName p, (packageIdentifier p, Local)) | p <- map lpPackage eeLocals] diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 6d03cc62b7..8b8df39f3e 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -70,6 +70,7 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package +import Stack.Types.PackageComponent (PackageComponentName) import Stack.Types.Version import System.FilePath (pathSeparator) import RIO.Process (showProcessArgDebug) @@ -513,8 +514,8 @@ installLocationIsMutable Local = Mutable -- | A complete plan of what needs to be built and how to do it data Plan = Plan - { planTasks :: !(Map PackageName Task) - , planFinals :: !(Map PackageName Task) + { planTasks :: !(Map PackageComponentName Task) + , planFinals :: !(Map PackageComponentName Task) -- ^ Final actions to be taken (test, benchmark, etc) , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text)) -- ^ Text is reason we're unregistering, for display only diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index 3b360f0a12..ca130a336e 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -22,12 +22,20 @@ import qualified Data.Set as Set import qualified Data.Text as T -- | A single, fully resolved component of a package +-- This type is Cabal based, and follows the .cabal files +-- possibilities. +-- These options are build targets. data NamedComponent = CLib + -- ^ The default library in a haskell project. | CInternalLib !Text + -- ^ An optional (named) internal library. | CExe !Text + -- ^ An executable. | CTest !Text + -- ^ A test target. | CBench !Text + -- ^ A benchmark target. deriving (Show, Eq, Ord) renderComponent :: NamedComponent -> Text diff --git a/src/Stack/Types/PackageComponent.hs b/src/Stack/Types/PackageComponent.hs new file mode 100644 index 0000000000..bbf6450ec6 --- /dev/null +++ b/src/Stack/Types/PackageComponent.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} + +module Stack.Types.PackageComponent where + +import Stack.Prelude +import Stack.Types.NamedComponent (NamedComponent(CLib)) + +-- | A tuple of a package name and component name (e.g. arrow:lib or stack:exec). +-- Required for component-addressed build plans. +-- Before introducing this, most packages were 'PackageName' addressed. +-- See +-- for more details. +data PackageComponentName = PackageComponentName { + packageName :: !PackageName, + componentName :: !NamedComponent +} deriving (Eq, Show, Ord) + +-- | This is needed for computing the largest packageName length in a BuildPlan. +-- See <../Build/Execute.hs#504 this file> +getPackageNameLength :: PackageComponentName -> Int +getPackageNameLength PackageComponentName{packageName=pn} = length . packageNameString $ pn + +-- | This is the main case for most packages, you only depend on their default library. +libraryPackage :: PackageName -> PackageComponentName +libraryPackage pckName = PackageComponentName { + packageName = pckName, + componentName = CLib + } + +-- | Ditch the @componentName :: NamedComponent@ part of a 'PackageComponentName'. +forgetComponentName :: PackageComponentName -> PackageName +forgetComponentName = packageName diff --git a/stack.cabal b/stack.cabal index 3176aa1f3c..e91b444b0a 100644 --- a/stack.cabal +++ b/stack.cabal @@ -218,6 +218,7 @@ library other-modules: Path.Extended Stack.Types.Cache + Stack.Types.PackageComponent autogen-modules: Paths_stack hs-source-dirs: diff --git a/stack.code-workspace b/stack.code-workspace new file mode 100644 index 0000000000..362d7c25bb --- /dev/null +++ b/stack.code-workspace @@ -0,0 +1,7 @@ +{ + "folders": [ + { + "path": "." + } + ] +} \ No newline at end of file