Update libarchive

.gitlab/script/ghcup_release.sh

@@ -17,7 +17,6 @@ ecabal update
 
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${BIT}" = "32" ] ; then
-		rm -r 3rdparty/libarchive
 		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
 	else
 		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui

3rdparty/libarchive/c/autoconf-linux/config.h

@@ -606,7 +606,7 @@
 /* #undef HAVE_LCHFLAGS */
 
 /* Define to 1 if you have the `lchmod' function. */
-#define HAVE_LCHMOD 1
+/* #undef HAVE_LCHMOD 1 */
 
 /* Define to 1 if you have the `lchown' function. */
 #define HAVE_LCHOWN 1
@@ -1028,10 +1028,10 @@
 /* #undef HAVE_STRUCT_STAT_ST_UMTIME */
 
 /* Define to 1 if `tm_gmtoff' is a member of `struct tm'. */
-#define HAVE_STRUCT_TM_TM_GMTOFF 1
+/* #undef HAVE_STRUCT_TM_TM_GMTOFF 1 */
 
 /* Define to 1 if `__tm_gmtoff' is a member of `struct tm'. */
-#define HAVE_STRUCT_TM___TM_GMTOFF 1
+/* #undef HAVE_STRUCT_TM___TM_GMTOFF 1 */
 
 /* Define to 1 if the system has the type `struct vfsconf'. */
 /* #undef HAVE_STRUCT_VFSCONF */

app/ghcup/BrickMain.hs

@@ -27,6 +27,7 @@ import           Control.Monad.Trans.Resource
 import           Data.Bool
 import           Data.Functor
 import           Data.List
+import           Data.Maybe
 import           Data.Char
 import           Data.IORef
 import           Data.String.Interpolate
@@ -51,6 +52,16 @@ data AppState = AppState {
 type LR = GenericList String Vector ListResult
 
 
+keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
+keyHandlers =
+  [ ('q', "Quit"     , halt)
+  , ('i', "Install"  , withIOAction install')
+  , ('u', "Uninstall", withIOAction del')
+  , ('s', "Set"      , withIOAction set')
+  , ('c', "ChangeLog", withIOAction changelog')
+  ]
+
+
 ui :: AppState -> Widget String
 ui AppState {..} =
   ( padBottom Max
@@ -59,15 +70,13 @@ ui AppState {..} =
       $ (center $ renderList renderItem True lr)
       )
     )
-    <=> foldr1
-          (\x y -> x <+> str "  " <+> y)
-          [ (str "q:Quit")
-          , (str "i:Install")
-          , (str "s:Set")
-          , (str "u:Uninstall")
-          , (str "c:ChangeLog")
-          , (str "↑↓:Navigation")
-          ]
+    <=> ( withAttr "help"
+        . txtWrap
+        . T.pack
+        . foldr1 (\x y -> x <> "  " <> y)
+        . (++ ["↑↓:Navigation"])
+        $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
+        )
 
  where
   renderItem b ListResult {..} =
@@ -83,11 +92,11 @@ ui AppState {..} =
             $ minHSize 20
             $ (withAttr
                 (bool "inactive" "active" b)
-                (str (fmap toLower . show $ lTool) <+> str " " <+> str ver)
+                (str $ (fmap toLower . show $ lTool) <> " " <> ver)
               )
             )
         <+> (padLeft (Pad 1) $ if null lTag
-              then str ""
+              then emptyWidget
               else
                 foldr1 (\x y -> x <+> str "," <+> y)
                   $ (fmap printTag $ sort lTag)
@@ -101,7 +110,7 @@ ui AppState {..} =
 
 
 minHSize :: Int -> Widget n -> Widget n
-minHSize s' = hLimit s' . vLimit 1 . (<+> str (replicate s' ' '))
+minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
 
 
 app :: App AppState e String
@@ -120,6 +129,7 @@ app = App { appDraw         = \st -> [ui st]
     , ("installed"    , fg Vty.green)
     , ("recommended"  , fg Vty.green)
     , ("latest"       , fg Vty.yellow)
+    , ("help"         , Vty.defAttr `Vty.withStyle` Vty.italic)
     ]
 
 
@@ -131,16 +141,22 @@ eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
   continue (AppState (listMoveUp lr) dls)
 eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
   continue (AppState (listMoveDown lr) dls)
-eventHandler AppState { dls = dls', lr = lr' } (VtyEvent (Vty.EvKey (Vty.KChar c) _))
-  | (Just (ix, e)) <- listSelectedElement lr'
-  , c `elem` ['i', 's', 'u', 'c']
-  = suspendAndResume $ do
-    r <- case c of
-      'i' -> install' e dls'
-      's' -> set' e
-      'u' -> del' e
-      'c' -> changelog' e dls'
-      _   -> error ""
+eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
+  case find (\(c', _, _) -> c' == c) keyHandlers of
+    Nothing              -> continue as
+    Just (_, _, handler) -> handler as
+eventHandler st _ = continue st
+
+
+-- | Suspend the current UI and run an IO action in terminal. If the
+-- IO action returns a Left value, then it's thrown as userError.
+withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
+             -> AppState
+             -> EventM n (Next AppState)
+withIOAction action as = case listSelectedElement (lr as) of
+  Nothing      -> continue as
+  Just (ix, e) -> suspendAndResume $ do
+    r <- action as (ix, e)
     case r of
       Left  err -> throwIO $ userError err
       Right _   -> do
@@ -148,17 +164,17 @@ eventHandler AppState { dls = dls', lr = lr' } (VtyEvent (Vty.EvKey (Vty.KChar c
           (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
           getAppState
         case apps of
-          Right as  -> do
+          Right nas -> do
             putStrLn "Press enter to continue"
             _ <- getLine
-            pure as
-          Left  err -> throwIO $ userError err
-eventHandler st _ = continue st
+            pure nas
+          Left err -> throwIO $ userError err
 
 
-install' :: ListResult -> GHCupDownloads -> IO (Either String ())
-install' ListResult {..} dls = do
-  l <- readIORef logger'
+install' :: AppState -> (Int, ListResult) -> IO (Either String ())
+install' AppState {..} (_, ListResult {..}) = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let
@@ -187,9 +203,10 @@ install' ListResult {..} dls = do
 Also check the logs in ~/.ghcup/logs|]
 
 
-set' :: ListResult -> IO (Either String ())
-set' ListResult {..} = do
-  l <- readIORef logger'
+set' :: AppState -> (Int, ListResult) -> IO (Either String ())
+set' _ (_, ListResult {..}) = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let run =
@@ -208,9 +225,10 @@ set' ListResult {..} = do
           VLeft  e -> pure $ Left [i|#{e}|]
 
 
-del' :: ListResult -> IO (Either String ())
-del' ListResult {..} = do
-  l <- readIORef logger'
+del' :: AppState -> (Int, ListResult) -> IO (Either String ())
+del' _ (_, ListResult {..}) = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -226,8 +244,8 @@ del' ListResult {..} = do
           VLeft  e -> pure $ Left [i|#{e}|]
 
 
-changelog' :: ListResult -> GHCupDownloads -> IO (Either String ())
-changelog' ListResult {..} dls = do
+changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
+changelog' AppState {..} (_, ListResult {..}) = do
   case getChangeLog dls lTool (Left lVer) of
     Nothing -> pure $ Left
       [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
@@ -237,12 +255,15 @@ changelog' ListResult {..} dls = do
         Left  e -> pure $ Left [i|#{e}|]
 
 
-settings :: Settings
-settings = Settings { cache      = True
-                    , noVerify   = False
-                    , keepDirs   = Never
-                    , downloader = Curl
-                    }
+settings' :: IORef Settings
+{-# NOINLINE settings' #-}
+settings' = unsafePerformIO
+  (newIORef Settings { cache      = True
+                     , noVerify   = False
+                     , keepDirs   = Never
+                     , downloader = Curl
+                     }
+  )
 
 
 logger' :: IORef LoggerConfig
@@ -255,23 +276,32 @@ logger' = unsafePerformIO
   )
 
 
-brickMain :: LoggerConfig -> IO ()
-brickMain l = do
+brickMain :: Settings -> LoggerConfig -> IO ()
+brickMain s l = do
+  writeIORef settings' s
   -- logger interpreter
-  writeIORef logger' l
+  writeIORef logger'   l
   let runLogger = myLoggerT l
 
   eApps <- getAppState
   case eApps of
-    Right as -> defaultMain app as $> ()
-    Left  _  -> do
-      runLogger ($(logError) [i|Error building app state|])
+    Right as -> defaultMain app (selectLatest as) $> ()
+    Left  e  -> do
+      runLogger ($(logError) [i|Error building app state: #{show e}|])
       exitWith $ ExitFailure 2
+ where
+  selectLatest :: AppState -> AppState
+  selectLatest AppState {..} =
+    (\ix -> AppState { lr = listMoveTo ix lr, .. })
+      . fromJust
+      . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
+      $ (listElements lr)
 
 
 getAppState :: IO (Either String AppState)
 getAppState = do
-  l <- readIORef logger'
+  settings <- readIORef settings'
+  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   r <-
@@ -282,10 +312,9 @@ getAppState = do
     $ do
         (GHCupInfo _ dls) <- liftE $ getDownloadsF GHCupURL
 
-        lV                 <- liftE $ listVersions dls Nothing Nothing
+        lV                <- liftE $ listVersions dls Nothing Nothing
         pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls)
 
   case r of
     VRight a -> pure $ Right a
     VLeft  e -> pure $ Left [i|#{e}|]
-

app/ghcup/Main.hs

@@ -1150,7 +1150,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
           res <- case optCommand of
 #if defined(BRICK)
-            Interactive -> liftIO $ brickMain loggerConfig >> pure ExitSuccess
+            Interactive -> liftIO $ brickMain settings loggerConfig >> pure ExitSuccess
 #endif
             Install (Right iopts) -> do
               runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])

ghcup.cabal

@@ -22,7 +22,7 @@ source-repository head
   location: https://gitlab.haskell.org/haskell/ghcup-hs.git
 
 flag tui
-  description: Build the brick powered tui (ghcup \-\-interactive)
+  description: Build the brick powered tui (ghcup tui)
   default:     False
   manual:      True
 

lib/GHCup.hs

@@ -928,7 +928,6 @@ upgradeGHCup dls mtarget force = do
           `unionFileModes` groupExecuteMode
           `unionFileModes` otherExecuteMode
   binDir <- liftIO $ ghcupBinDir
-  liftIO $ createDirIfMissing newDirPerms binDir
   let fullDest = fromMaybe (binDir </> fn) mtarget
   liftIO $ hideError NoSuchThing $ deleteFile fullDest
   handleIO (throwE . CopyError . show) $ liftIO $ copyFile p