Let cabal init remember chosen language within current session (has…

…kell#10115)

* Add session to keep last chosen language

* Drop do block in initCmd

* Rename _runPrompt to runPrompt

* Rename _runPromptState to runPromptState

* Add type alias for NonEmpty String as Inputs

* Split fmap and rename newSessionState

* Rename arguments based on input and session (state)

* Update UnitTest regarding _runPrompt rename

* Make PromptIO a newtype

* Formatting

* Drop unneeded extensions

* Hide MonadReader to consumes of PromptIO

---------

Co-authored-by: brandon s allbery kf8nh <[email protected]>

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

@@ -41,8 +41,7 @@ initCmd v packageDBs repoCtxt comp progdb initFlags = do
   installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
   sourcePkgDb <- getSourcePackages v repoCtxt
   hSetBuffering stdout NoBuffering
-  settings <- createProject v installedPkgIndex sourcePkgDb initFlags
-  writeProject settings
+  runPromptIO (writeProject =<< createProject v installedPkgIndex sourcePkgDb initFlags)
   where
     -- When no flag is set, default to interactive.
     --

cabal-install/src/Distribution/Client/Init/Interactive/Command.hs

@@ -460,14 +460,18 @@ languagePrompt flags pkgType = getLanguage flags $ do
       ghc2021 = "GHC2021 (requires at least GHC 9.2)"
       ghc2024 = "GHC2024 (requires at least GHC 9.10)"
 
+  lastChosenLanguage <- getLastChosenLanguage
+
   l <-
     promptList
       ("Choose a language for your " ++ pkgType)
       [h2010, h98, ghc2021, ghc2024]
-      (DefaultPrompt h2010)
+      (DefaultPrompt (maybe h2010 id lastChosenLanguage))
       Nothing
       True
 
+  setLastChosenLanguage (Just l)
+
   if
       | l == h2010 -> return Haskell2010
       | l == h98 -> return Haskell98

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 
 -- |
@@ -39,7 +40,11 @@ module Distribution.Client.Init.Types
     -- * Typeclasses
   , Interactive (..)
   , BreakException (..)
-  , PurePrompt (..)
+  , PromptIO
+  , runPromptIO
+  , Inputs
+  , PurePrompt
+  , runPrompt
   , evalPrompt
   , Severity (..)
 
@@ -63,9 +68,12 @@ import qualified Distribution.Client.Compat.Prelude as P
 import Prelude (read)
 
 import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Reader
 
 import Data.List.NonEmpty (fromList)
 
+import qualified Data.IORef
 import Distribution.CabalSpecVersion
 import Distribution.Client.Utils as P
 import Distribution.Fields.Pretty
@@ -282,15 +290,33 @@ mkLiterate _ hs = hs
 -- -------------------------------------------------------------------- --
 -- Interactive prompt monad
 
+newtype PromptIO a = PromptIO (ReaderT (Data.IORef.IORef SessionState) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+sessionState :: PromptIO (Data.IORef.IORef SessionState)
+sessionState = PromptIO ask
+
+runPromptIO :: PromptIO a -> IO a
+runPromptIO (PromptIO pio) =
+  (Data.IORef.newIORef newSessionState) >>= (runReaderT pio)
+
+type Inputs = NonEmpty String
+
 newtype PurePrompt a = PurePrompt
-  { _runPrompt
-      :: NonEmpty String
-      -> Either BreakException (a, NonEmpty String)
+  { runPromptState
+      :: (Inputs, SessionState)
+      -> Either BreakException (a, (Inputs, SessionState))
   }
   deriving (Functor)
 
-evalPrompt :: PurePrompt a -> NonEmpty String -> a
-evalPrompt act s = case _runPrompt act s of
+runPrompt :: PurePrompt a -> Inputs -> Either BreakException (a, Inputs)
+runPrompt act args =
+  fmap
+    (\(a, (s, _)) -> (a, s))
+    (runPromptState act (args, newSessionState))
+
+evalPrompt :: PurePrompt a -> Inputs -> a
+evalPrompt act s = case runPrompt act s of
   Left e -> error $ show e
   Right (a, _) -> a
 
@@ -306,7 +332,7 @@ instance Monad PurePrompt where
   return = pure
   PurePrompt a >>= k = PurePrompt $ \s -> case a s of
     Left e -> Left e
-    Right (a', s') -> _runPrompt (k a') s'
+    Right (a', s') -> runPromptState (k a') s'
 
 class Monad m => Interactive m where
   -- input functions
@@ -341,36 +367,61 @@ class Monad m => Interactive m where
   break :: m Bool
   throwPrompt :: BreakException -> m a
 
-instance Interactive IO where
-  getLine = P.getLine
-  readFile = P.readFile
-  getCurrentDirectory = P.getCurrentDirectory
-  getHomeDirectory = P.getHomeDirectory
-  getDirectoryContents = P.getDirectoryContents
-  listDirectory = P.listDirectory
-  doesDirectoryExist = P.doesDirectoryExist
-  doesFileExist = P.doesFileExist
-  canonicalizePathNoThrow = P.canonicalizePathNoThrow
-  readProcessWithExitCode = Process.readProcessWithExitCode
-  getEnvironment = P.getEnvironment
-  getCurrentYear = P.getCurrentYear
-  listFilesInside = P.listFilesInside
-  listFilesRecursive = P.listFilesRecursive
-
-  putStr = P.putStr
-  putStrLn = P.putStrLn
-  createDirectory = P.createDirectory
-  removeDirectory = P.removeDirectoryRecursive
-  writeFile = P.writeFile
-  removeExistingFile = P.removeExistingFile
-  copyFile = P.copyFile
-  renameDirectory = P.renameDirectory
-  hFlush = System.IO.hFlush
+  -- session state functions
+  getLastChosenLanguage :: m (Maybe String)
+  setLastChosenLanguage :: (Maybe String) -> m ()
+
+newtype SessionState = SessionState
+  { lastChosenLanguage :: (Maybe String)
+  }
+
+newSessionState :: SessionState
+newSessionState = SessionState{lastChosenLanguage = Nothing}
+
+instance Interactive PromptIO where
+  getLine = liftIO P.getLine
+  readFile = liftIO <$> P.readFile
+  getCurrentDirectory = liftIO P.getCurrentDirectory
+  getHomeDirectory = liftIO P.getHomeDirectory
+  getDirectoryContents = liftIO <$> P.getDirectoryContents
+  listDirectory = liftIO <$> P.listDirectory
+  doesDirectoryExist = liftIO <$> P.doesDirectoryExist
+  doesFileExist = liftIO <$> P.doesFileExist
+  canonicalizePathNoThrow = liftIO <$> P.canonicalizePathNoThrow
+  readProcessWithExitCode a b c = liftIO $ Process.readProcessWithExitCode a b c
+  getEnvironment = liftIO P.getEnvironment
+  getCurrentYear = liftIO P.getCurrentYear
+  listFilesInside test dir = do
+    -- test is run within a new env and not the current env
+    -- all usages of listFilesInside are pure functions actually
+    liftIO $ P.listFilesInside (\f -> liftIO $ runPromptIO (test f)) dir
+  listFilesRecursive = liftIO <$> P.listFilesRecursive
+
+  putStr = liftIO <$> P.putStr
+  putStrLn = liftIO <$> P.putStrLn
+  createDirectory = liftIO <$> P.createDirectory
+  removeDirectory = liftIO <$> P.removeDirectoryRecursive
+  writeFile a b = liftIO $ P.writeFile a b
+  removeExistingFile = liftIO <$> P.removeExistingFile
+  copyFile a b = liftIO $ P.copyFile a b
+  renameDirectory a b = liftIO $ P.renameDirectory a b
+  hFlush = liftIO <$> System.IO.hFlush
   message q severity msg
     | q == silent = pure ()
     | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg
   break = return False
-  throwPrompt = throwM
+  throwPrompt = liftIO <$> throwM
+
+  getLastChosenLanguage = do
+    stateRef <- sessionState
+    liftIO $ lastChosenLanguage <$> Data.IORef.readIORef stateRef
+
+  setLastChosenLanguage value = do
+    stateRef <- sessionState
+    liftIO $
+      Data.IORef.modifyIORef
+        stateRef
+        (\state -> state{lastChosenLanguage = value})
 
 instance Interactive PurePrompt where
   getLine = pop
@@ -411,13 +462,18 @@ instance Interactive PurePrompt where
     _ -> return ()
 
   break = return True
-  throwPrompt (BreakException e) = PurePrompt $ \s ->
+  throwPrompt (BreakException e) = PurePrompt $ \(i, _) ->
     Left $
       BreakException
-        ("Error: " ++ e ++ "\nStacktrace: " ++ show s)
+        ("Error: " ++ e ++ "\nStacktrace: " ++ show i)
+
+  getLastChosenLanguage = PurePrompt $ \(i, s) ->
+    Right (lastChosenLanguage s, (i, s))
+  setLastChosenLanguage l = PurePrompt $ \(i, s) ->
+    Right ((), (i, s{lastChosenLanguage = l}))
 
 pop :: PurePrompt String
-pop = PurePrompt $ \(p :| ps) -> Right (p, fromList ps)
+pop = PurePrompt $ \(i :| is, s) -> Right (i, (fromList is, s))
 
 popAbsolute :: PurePrompt String
 popAbsolute = do
@@ -429,7 +485,7 @@ popBool =
   pop >>= \case
     "True" -> pure True
     "False" -> pure False
-    s -> throwPrompt $ BreakException $ "popBool: " ++ s
+    i -> throwPrompt $ BreakException $ "popBool: " ++ i
 
 popList :: PurePrompt [String]
 popList =

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

@@ -99,7 +99,7 @@ import System.IO.Error
 
 import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)
 import Distribution.Client.Init.Prompt (promptYesNo)
-import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt))
+import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO)
 import Distribution.Client.Types.OverwritePolicy
 
 import qualified Data.ByteString as BS
@@ -336,7 +336,7 @@ symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateNam
 
 promptRun :: String -> IO Bool -> IO Bool
 promptRun s m = do
-  a <- promptYesNo s MandatoryPrompt
+  a <- runPromptIO $ promptYesNo s MandatoryPrompt
   if a then m else pure a
 
 -- | Check a file path of a symlink that we would like to create to see if it

cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs

@@ -26,7 +26,7 @@ import Distribution.Simple.LocalBuildInfo
   )
 
 import qualified Data.Set as Set
-import Distribution.Client.Init.Types (removeExistingFile)
+import Distribution.Client.Init.Types (removeExistingFile, runPromptIO)
 
 -----------------------------
 -- Package change detection
@@ -291,4 +291,4 @@ updatePackageRegFileMonitor
 
 invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
 invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
-  removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
+  runPromptIO $ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)

cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs

@@ -81,7 +81,7 @@ tests _v _initFlags comp pkgIx srcDb =
                 "False"
               ]
 
-        case flip _runPrompt inputs $ do
+        case flip runPrompt inputs $ do
           projSettings <- createProject comp silent pkgIx srcDb dummyFlags'
           writeProject projSettings of
           Left (BreakException ex) -> assertFailure $ show ex

cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs

@@ -105,7 +105,7 @@ goldenPkgDescTests v srcDb pkgDir pkgName =
     ]
   where
     runPkgDesc opts flags args = do
-      case _runPrompt (genPkgDescription flags srcDb) args of
+      case runPrompt (genPkgDescription flags srcDb) args of
         Left e -> assertFailure $ show e
         Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg
 
@@ -146,7 +146,7 @@ goldenExeTests v pkgIx pkgDir pkgName =
     ]
   where
     runGoldenExe opts args flags =
-      case _runPrompt (genExeTarget flags pkgIx) args of
+      case runPrompt (genExeTarget flags pkgIx) args of
         Right (t, _) -> mkStanza [mkExeStanza opts $ t{_exeDependencies = mangleBaseDep t _exeDependencies}]
         Left e -> assertFailure $ show e
 
@@ -192,7 +192,7 @@ goldenLibTests v pkgIx pkgDir pkgName =
     ]
   where
     runGoldenLib opts args flags =
-      case _runPrompt (genLibTarget flags pkgIx) args of
+      case runPrompt (genLibTarget flags pkgIx) args of
         Right (t, _) -> mkStanza [mkLibStanza opts $ t{_libDependencies = mangleBaseDep t _libDependencies}]
         Left e -> assertFailure $ show e
 
@@ -243,7 +243,7 @@ goldenTestTests v pkgIx pkgDir pkgName =
     ]
   where
     runGoldenTest opts args flags =
-      case _runPrompt (genTestTarget flags pkgIx) args of
+      case runPrompt (genTestTarget flags pkgIx) args of
         Left e -> assertFailure $ show e
         Right (Nothing, _) ->
           assertFailure
@@ -286,7 +286,7 @@ goldenCabalTests v pkgIx srcDb =
     ]
   where
     runGoldenTest args flags =
-      case _runPrompt (createProject v pkgIx srcDb flags) args of
+      case runPrompt (createProject v pkgIx srcDb flags) args of
         Left e -> assertFailure $ show e
         (Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do
           let pkgFields = mkPkgDescription opts pkgDesc