Merge pull request #6488 from commercialhaskell/getRawSnapshot

Eliminate some code duplication
commercialhaskell · Feb 17, 2024 · cc1f6df · cc1f6df
2 parents 12005d6 + 4bba686
commit cc1f6df
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 21 deletions.
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -23,6 +23,7 @@ module Stack.Config
   , getImplicitGlobalProjectDir
   , getSnapshots
   , makeConcreteSnapshot
+  , getRawSnapshot
   , checkOwnership
   , getInContainer
   , getInNixShell
@@ -56,6 +57,7 @@ import           GHC.Conc ( getNumProcessors )
 import           Network.HTTP.StackClient
                    ( httpJSON, parseUrlThrow, getResponseBody )
 import           Options.Applicative ( Parser, help, long, metavar, strOption )
+import           Pantry ( loadSnapshot )
 import           Path
                    ( PathException (..), (</>), parent, parseAbsDir
                    , parseAbsFile, parseRelDir, stripProperPrefix
@@ -247,6 +249,15 @@ makeConcreteSnapshot as = do
     ]
   pure s
 
+-- | Get the raw snapshot from the global options.
+getRawSnapshot :: HasConfig env => RIO env (Maybe RawSnapshot)
+getRawSnapshot = do
+  mASnapshot <- view $ globalOptsL . to (.snapshot)
+  forM mASnapshot $ \aSnapshot -> do
+    concrete <- makeConcreteSnapshot aSnapshot
+    loc <- completeSnapshotLocation concrete
+    loadSnapshot loc
+
 -- | Get the latest snapshot available.
 getLatestSnapshot :: HasConfig env => RIO env RawSnapshotLocation
 getLatestSnapshot = do
@@ -670,7 +681,7 @@ loadConfig ::
 loadConfig inner = do
   mstackYaml <- view $ globalOptsL . to (.stackYaml)
   mproject <- loadProjectConfig mstackYaml
-  mSnapshot <- view $ globalOptsL . to (.snapshot)
+  mASnapshot <- view $ globalOptsL . to (.snapshot)
   configArgs <- view $ globalOptsL . to (.configMonoid)
   (configRoot, stackRoot, userOwnsStackRoot) <-
     determineStackRootAndOwnership configArgs
@@ -695,7 +706,7 @@ loadConfig inner = do
         configFromConfigMonoid
           stackRoot
           userConfigPath
-          mSnapshot
+          mASnapshot
           mproject'
           (mconcat $ configArgs : addConfigMonoid extraConfigs)
 

diff --git a/src/Stack/List.hs b/src/Stack/List.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
 -- | Types and functions related to Stack's @list@ command.
@@ -8,15 +7,13 @@ module Stack.List
   , listPackages
   ) where
 
-import           Pantry ( loadSnapshot )
 import qualified RIO.ByteString.Lazy as Lazy
 import qualified RIO.Map as Map
 import           RIO.Process ( HasProcessContext )
-import           Stack.Config ( makeConcreteSnapshot )
+import           Stack.Config ( getRawSnapshot )
 import           Stack.Prelude
 import           Stack.Runners ( ShouldReexec (..), withConfig )
-import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
-import           Stack.Types.Runner ( Runner, globalOptsL )
+import           Stack.Types.Runner ( Runner )
 
 -- | Type representing exceptions thrown by functions exported by the
 -- "Stack.List" module.
@@ -35,11 +32,7 @@ instance Exception ListPrettyException
 -- | Function underlying the @stack list@ command. List packages.
 listCmd :: [String] -> RIO Runner ()
 listCmd names = withConfig NoReexec $ do
-  mASnapshot <- view $ globalOptsL . to (.snapshot)
-  mSnapshot <- forM mASnapshot $ \aSnapshot -> do
-    concrete <- makeConcreteSnapshot aSnapshot
-    loc <- completeSnapshotLocation concrete
-    loadSnapshot loc
+  mSnapshot <- getRawSnapshot
   listPackages mSnapshot names
 
 -- | Intended to work for the command line command.

diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs
@@ -14,18 +14,16 @@ module Stack.Unpack
 import           Data.List.Extra ( notNull )
 import           Path ( SomeBase (..), (</>), parseRelDir )
 import           Path.IO ( doesDirExist, getCurrentDir )
-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 ( makeConcreteSnapshot )
+import           Stack.Config ( getRawSnapshot )
 import           Stack.Constants ( relDirRoot )
 import           Stack.Prelude
 import           Stack.Runners ( ShouldReexec (..), withConfig )
 import           Stack.Types.Config ( Config (..), HasConfig, configL )
-import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
-import           Stack.Types.Runner ( Runner, globalOptsL )
+import           Stack.Types.Runner ( Runner )
 
 -- | Type representing \'pretty\' exceptions thrown by functions exported by the
 -- "Stack.Unpack" module.
@@ -94,11 +92,7 @@ unpackCmd (UnpackOpts targets areCandidates Nothing) =
   unpackCmd (UnpackOpts targets areCandidates (Just $ Rel relDirRoot))
 unpackCmd (UnpackOpts targets areCandidates (Just dstPath)) =
   withConfig NoReexec $ do
-    mASnapshot <- view $ globalOptsL . to (.snapshot)
-    mSnapshot <- forM mASnapshot $ \aSnapshot -> do
-      concrete <- makeConcreteSnapshot aSnapshot
-      loc <- completeSnapshotLocation concrete
-      loadSnapshot loc
+    mSnapshot <- getRawSnapshot
     dstPath' <- case dstPath of
       Abs path -> pure path
       Rel path -> do