From 4152ab292a8e18c16ee6e3a9ff633cb3ab15fccd Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sat, 24 Jun 2023 09:50:30 -0400 Subject: [PATCH 1/3] Unpack a repo extra-dep --- src/Stack/Config.hs | 1 + src/Stack/Unpack.hs | 122 ++++++++++++++++++++++++++++++++++++++------ 2 files changed, 106 insertions(+), 17 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 94cb5680f4..0328606d56 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -18,6 +18,7 @@ module Stack.Config ( loadConfig , loadConfigYaml + , loadProjectConfig , packagesParser , getImplicitGlobalProjectDir , getSnapshots diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 98c8f3cb90..090cb52bc3 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,6 +8,7 @@ module Stack.Unpack , unpackPackages ) where +import qualified Data.List as L import Path ( (), parseRelDir ) import Path.IO ( doesDirExist, resolveDir' ) import Pantry ( loadSnapshot ) @@ -14,11 +16,20 @@ import qualified RIO.Map as Map import RIO.Process ( HasProcessContext ) import qualified RIO.Set as Set import qualified RIO.Text as T -import Stack.Config ( makeConcreteResolver ) +import Stack.Config ( loadProjectConfig, makeConcreteResolver ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig ) +import Stack.Types.Project ( Project (..) ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) +import Stack.Types.ProjectConfig ( ProjectConfig (..) ) import Stack.Types.Runner ( Runner, globalOptsL ) +import Stack.Types.StackYamlLoc ( StackYamlLoc (..) ) +import Distribution.Types.PackageName ( unPackageName ) + +data Unpackable + = UnpackName PackageName + | UnpackIdent PackageIdentifierRevision + | UnpackRepoUrl (PackageName, RawPackageLocationImmutable) -- | Type representing \'pretty\' exceptions thrown by functions exported by the -- "Stack.Unpack" module. @@ -54,24 +65,41 @@ unpackCmd :: -> RIO Runner () unpackCmd (names, Nothing) = unpackCmd (names, Just ".") unpackCmd (names, Just dstPath) = withConfig NoReexec $ do + mStackYaml <- view $ globalOptsL.to globalStackYaml mresolver <- view $ globalOptsL.to globalResolver mSnapshot <- forM mresolver $ \resolver -> do concrete <- makeConcreteResolver resolver loc <- completeSnapshotLocation concrete loadSnapshot loc dstPath' <- resolveDir' $ T.unpack dstPath - unpackPackages mSnapshot dstPath' names + unpackPackages mStackYaml mSnapshot dstPath' names -- | Intended to work for the command line command. unpackPackages :: forall env. (HasPantryConfig env, HasProcessContext env, HasTerm env) - => Maybe RawSnapshot -- ^ When looking up by name, take from this build plan. + => StackYamlLoc + -> Maybe RawSnapshot -- ^ When looking up by name, take from this build plan. -> Path Abs Dir -- ^ Destination. -> [String] -- ^ Names or identifiers. -> RIO env () -unpackPackages mSnapshot dest input = do - let (errs1, (names, pirs1)) = - fmap partitionEithers $ partitionEithers $ map parse input +unpackPackages mStackYaml mSnapshot dest input = do + parsed <- mapM (parse mStackYaml) input + let (errs1, unpackables) = partitionEithers parsed + let (names, pirs1, raws) = splitUnpackable unpackables + + repos <- catMaybes <$> mapM + (\case + (name, x@RPLIRepo{}) -> do + suffix <- parseRelDir $ unPackageName name + pure $ Just (x, dest suffix) + (_, RPLIHackage{}) -> pure Nothing + (_, RPLIArchive{}) -> pure Nothing) + (longestUnique raws) + + forM_ repos $ \(loc, dest') -> do + unpackPackageLocationRaw dest' loc + prettyInfoL $ unpackMessage loc dest' + locs1 <- forM pirs1 $ \pir -> do loc <- fmap cplComplete $ completePackageLocation $ RPLIHackage pir Nothing pure (loc, packageLocationIdent loc) @@ -93,12 +121,7 @@ unpackPackages mSnapshot dest input = do forM_ (Map.toList locs) $ \(loc, dest') -> do unpackPackageLocation dest' loc - prettyInfoL - [ "Unpacked" - , fromString $ T.unpack $ textDisplay loc - , "to" - , pretty dest' <> "." - ] + prettyInfoL $ unpackMessage loc dest' where toLoc | Just snapshot <- mSnapshot = toLocSnapshot snapshot | otherwise = toLocNoSnapshot @@ -158,14 +181,79 @@ unpackPackages mSnapshot dest input = do loc <- cplComplete <$> completePackageLocation (rspLocation sp) pure $ Right (loc, packageLocationIdent loc) - -- Possible future enhancement: parse names as name + version range - parse s = - case parsePackageName s of - Just x -> Right $ Left x +-- Possible future enhancement: parse names as name + version range +parse :: + (HasPantryConfig env, HasTerm env) + => StackYamlLoc -> String -> RIO env (Either StyleDoc Unpackable) +parse mStackYaml s = do + extra <- toLocExtraDep mStackYaml (fromString s) + pure $ case extra of + Just x -> Right $ UnpackRepoUrl x + Nothing -> case parsePackageName s of + Just x -> Right $ UnpackName x Nothing -> case parsePackageIdentifierRevision (T.pack s) of - Right x -> Right $ Right x + Right x -> Right $ UnpackIdent x Left _ -> Left $ fillSep [ flow "Could not parse as package name or identifier:" , style Current (fromString s) <> "." ] + +toLocExtraDep :: + (HasPantryConfig env, HasTerm env) + => StackYamlLoc + -> PackageName + -> RIO env (Maybe (PackageName, RawPackageLocationImmutable)) +toLocExtraDep mstackYaml name = do + pc <- loadProjectConfig mstackYaml + case pc of + PCGlobalProject -> pure Nothing + PCNoProject{} -> pure Nothing + PCProject (Project{projectDependencies}, _, _) -> do + let hits = mapMaybe (\case + RPLImmutable (RPLIRepo repo meta@RawPackageMetadata{rpmName = Just n}) -> do + if n == name then Just (name, (repo, meta)) else Nothing + RPLImmutable (RPLIRepo repo@Repo{repoUrl} meta) -> do + if T.isSuffixOf (T.pack $ unPackageName name) repoUrl then Just (name, (repo, meta)) else Nothing + RPLMutable{} -> Nothing + RPLImmutable{} -> Nothing) projectDependencies + + case hits of + [] -> pure Nothing + [(n, (repo, meta))] -> pure $ Just (n, RPLIRepo repo meta) + _ -> do + prettyWarnL + [ flow "Multiple matches for" + , style Current (fromString $ packageNameString name) <> ":" + ] + forM_ hits $ \case + (_, (repo, RawPackageMetadata{rpmName})) -> do + prettyWarnL + [ style Current (fromString . T.unpack $ repoUrl repo) + , style Current (fromString $ maybe "" unPackageName rpmName) + ] + pure Nothing + +splitUnpackable :: + [Unpackable] + -> ([PackageName], [PackageIdentifierRevision], [(PackageName, RawPackageLocationImmutable)]) +splitUnpackable = foldl' go ([], [], []) + where + go (names, pirs, raws) = \case + UnpackName name -> (name : names, pirs, raws) + UnpackIdent pir -> (names, pir : pirs, raws) + UnpackRepoUrl raw -> (names, pirs, raw : raws) + +longestUnique :: + [(PackageName, RawPackageLocationImmutable)] + -> [(PackageName, RawPackageLocationImmutable)] +longestUnique xs = + L.concat $ L.groupBy (\(_, p1) (_, p2) -> p1 == p2) (L.take 1 $ L.sortBy (flip (comparing fst)) xs) + +unpackMessage :: Display a => a -> Path Abs Dir -> [StyleDoc] +unpackMessage loc dest = + [ "Unpacked" + , fromString $ T.unpack $ textDisplay loc + , "to" + , pretty dest <> "." + ] \ No newline at end of file From a07b402115a58f642f59ea13c6a58f9e47b3402e Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sat, 24 Jun 2023 13:33:14 -0400 Subject: [PATCH 2/3] Add docs and change log entry. --- ChangeLog.md | 2 ++ doc/unpack_command.md | 3 +++ 2 files changed, 5 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 90765c592e..89b5ce2888 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,6 +10,8 @@ Release notes: matching cargo behavior and preventing logSticky spam on narrow terminals and lots of dependencies building simultaneously +* Add unpacking of source repository packages (`extra-deps`). + **Changes since v2.11.1:** Major changes: diff --git a/doc/unpack_command.md b/doc/unpack_command.md index 544aa71211..ff7c93f580 100644 --- a/doc/unpack_command.md +++ b/doc/unpack_command.md @@ -17,3 +17,6 @@ By default: * the package is unpacked into a directory named after the package and its version. Pass the option `--to ` to specify the destination directory. + +If PACKAGE is the name of a source repository package or a suffix of its URL +then the unpacking is direct, not via a package index. \ No newline at end of file From cbdad843356c0041d4857a9c275a15beaf60cec1 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Sat, 24 Jun 2023 13:41:05 -0400 Subject: [PATCH 3/3] Satisfy hlint. --- src/Stack/Unpack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 090cb52bc3..80ca87bfb3 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -248,7 +248,7 @@ longestUnique :: [(PackageName, RawPackageLocationImmutable)] -> [(PackageName, RawPackageLocationImmutable)] longestUnique xs = - L.concat $ L.groupBy (\(_, p1) (_, p2) -> p1 == p2) (L.take 1 $ L.sortBy (flip (comparing fst)) xs) + L.concat $ L.groupBy (\(_, p1) (_, p2) -> p1 == p2) (L.take 1 $ L.sortOn (Down . fst) xs) unpackMessage :: Display a => a -> Path Abs Dir -> [StyleDoc] unpackMessage loc dest =