Unpack a repo extra-dep

Author: philderbeast

src/Stack/Config.hs

@@ -18,6 +18,7 @@
 module Stack.Config
   ( loadConfig
   , loadConfigYaml
+  , loadProjectConfig
   , packagesParser
   , getImplicitGlobalProjectDir
   , getSnapshots

src/Stack/Unpack.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
@@ -7,18 +8,28 @@ module Stack.Unpack
   , unpackPackages
   ) where
 
+import qualified Data.List as L
 import           Path ( (</>), parseRelDir )
 import           Path.IO ( doesDirExist, resolveDir' )
 import           Pantry ( loadSnapshot )
 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 <> "."
+  ]