Improve logging on broken symlinks wrt #880

app/ghcup/BrickMain.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ViewPatterns      #-}
-{-# LANGUAGE TemplateHaskell   #-}
 
 module BrickMain where
 
@@ -26,7 +25,6 @@ import           Brick
 import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Center
-import           Brick.Widgets.Dialog (buttonSelectedAttr)
 import           Brick.Widgets.List             ( listSelectedFocusedAttr
                                                 , listSelectedAttr
                                                 , listAttr
@@ -43,11 +41,11 @@ import           Data.Bool
 import           Data.Functor
 import           Data.List
 import           Data.Maybe
-import           Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
+import           Data.IORef
 import           Data.Vector                    ( Vector
                                                 , (!?)
                                                 )
-import           Data.Versions           hiding ( str, Lens' )
+import           Data.Versions           hiding ( str )
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( appendFile )
 import           System.FilePath
@@ -63,84 +61,68 @@ import qualified Graphics.Vty                  as Vty
 import qualified Data.Vector                   as V
 import System.Environment (getExecutablePath)
 import qualified System.Posix.Process          as SPP
-import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ( (.=), use, (%=), view )
-import Lens.Micro ((.~), (&))
+
 
 hiddenTools :: [Tool]
-hiddenTools = [] 
+hiddenTools = []
+
 
 data BrickData = BrickData
-  { _lr    :: [ListResult]
+  { lr    :: [ListResult]
   }
   deriving Show
 
-makeLenses ''BrickData
-
 data BrickSettings = BrickSettings
-  { _showAllVersions    :: Bool
-  , _showAllTools       :: Bool
+  { showAllVersions    :: Bool
+  , showAllTools       :: Bool
   }
-  --deriving Show
-
-makeLenses ''BrickSettings
+  deriving Show
 
 data BrickInternalState = BrickInternalState
-  { _clr   :: Vector ListResult
-  , _ix    :: Int
+  { clr :: Vector ListResult
+  , ix  :: Int
   }
-  --deriving Show
-
-makeLenses ''BrickInternalState
+  deriving Show
 
 data BrickState = BrickState
-  { _appData     :: BrickData
-  , _appSettings :: BrickSettings
-  , _appState    :: BrickInternalState
-  , _appKeys     :: KeyBindings
+  { appData     :: BrickData
+  , appSettings :: BrickSettings
+  , appState    :: BrickInternalState
+  , appKeys     :: KeyBindings
   }
-  --deriving Show
+  deriving Show
 
-makeLenses ''BrickState
 
 keyHandlers :: KeyBindings
             -> [ ( Vty.Key
                  , BrickSettings -> String
-                 , EventM String BrickState ()
+                 , BrickState -> EventM String BrickState ()
                  )
                ]
 keyHandlers KeyBindings {..} =
-  [ (bQuit, const "Quit"     , halt)
+  [ (bQuit, const "Quit"     , \_ -> halt)
   , (bInstall, const "Install"  , withIOAction install')
   , (bUninstall, const "Uninstall", withIOAction del')
   , (bSet, const "Set"      , withIOAction set')
   , (bChangelog, const "ChangeLog", withIOAction changelog')
   , ( bShowAllVersions
     , \BrickSettings {..} ->
-       if _showAllVersions then "Don't show all versions" else "Show all versions"
-    , hideShowHandler' (not . _showAllVersions) _showAllTools
+       if showAllVersions then "Don't show all versions" else "Show all versions"
+    , hideShowHandler (not . showAllVersions) showAllTools
     )
   , ( bShowAllTools
     , \BrickSettings {..} ->
-       if _showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler' _showAllVersions (not . _showAllTools)
+       if showAllTools then "Don't show all tools" else "Show all tools"
+    , hideShowHandler showAllVersions (not . showAllTools)
     )
-  , (bUp, const "Up", appState %= moveCursor 1 Up)
-  , (bDown, const "Down", appState %= moveCursor 1 Down)
+  , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
+  , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
   ]
  where
-  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
-  hideShowHandler' f p = do 
-    app_settings <- use appSettings
-    let 
-      vers = f app_settings
-      tools = p app_settings
-      newAppSettings = app_settings & showAllVersions .~ vers & showAllTools .~ tools
-    ad <- use appData
-    current_app_state <- use appState
-    appSettings .= newAppSettings
-    appState    .= constructList ad app_settings (Just current_app_state)
-
+  hideShowHandler f p BrickState{..} =
+    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+        newInternalState = constructList appData newAppSettings (Just appState)
+    in  put (BrickState appData newAppSettings newInternalState appKeys)
 
 
 showKey :: Vty.Key -> String
@@ -149,12 +131,13 @@ showKey Vty.KUp = "↑"
 showKey Vty.KDown = "↓"
 showKey key = tail (show key)
 
+
 ui :: AttrMap -> BrickState -> Widget String
-ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
+ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
   = padBottom Max
       ( withBorderStyle unicode
         $ borderWithLabel (str "GHCup")
-          (center (header <=> hBorder <=> renderList' _appState))
+          (center (header <=> hBorder <=> renderList' appState))
       )
     <=> footer
 
@@ -165,7 +148,7 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
       . T.pack
       . foldr1 (\x y -> x <> "  " <> y)
       . fmap (\(key, s, _) -> showKey key <> ":" <> s as)
-      $ keyHandlers _appKeys
+      $ keyHandlers appKeys
   header =
     minHSize 2 emptyWidget
       <+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
@@ -173,8 +156,8 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
       <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
       <+> padLeft (Pad 5) (str "Notes")
   renderList' bis@BrickInternalState{..} =
-    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) _clr
-        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) _clr
+    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
+        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
     in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
   renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
     let marks = if
@@ -280,10 +263,11 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
 minHSize :: Int -> Widget n -> Widget n
 minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
 
-app :: AttrMap -> AttrMap -> App BrickState () String
+
+app :: AttrMap -> AttrMap -> App BrickState e String
 app attrs dimAttrs =
-  App { appDraw     = \st -> [ui dimAttrs st]
-  , appHandleEvent  = eventHandler
+  App { appDraw         = \st -> [ui dimAttrs st]
+  , appHandleEvent  = \be -> get >>= \s -> eventHandler s be
   , appStartEvent   = return ()
   , appAttrMap      = const attrs
   , appChooseCursor = showFirstCursor
@@ -308,7 +292,6 @@ defaultAttributes no_color = attrMap
   , (attrName "day"               , Vty.defAttr `withForeColor` Vty.blue)
   , (attrName "help"              , Vty.defAttr `withStyle`     Vty.italic)
   , (attrName "hooray"            , Vty.defAttr `withForeColor` Vty.brightWhite)
-  , (buttonSelectedAttr           , Vty.defAttr `withBackColor` Vty.brightWhite)
   ]
   where
     withForeColor | no_color  = const
@@ -329,51 +312,56 @@ dimAttributes no_color = attrMap
     withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
                   | otherwise = Vty.withBackColor
 
-eventHandler :: BrickEvent String e -> EventM String BrickState ()
-eventHandler ev = do
+eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
+eventHandler st@BrickState{..} ev = do
   AppState { keyBindings = kb } <- liftIO $ readIORef settings'
   case ev of
-    (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
-    (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
-    (VtyEvent (Vty.EvResize _ _)) -> pure ()
-    (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
-    (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
+    (MouseDown _ Vty.BScrollUp _ _) ->
+      put (BrickState { appState = moveCursor 1 appState Up, .. })
+    (MouseDown _ Vty.BScrollDown _ _) ->
+      put (BrickState { appState = moveCursor 1 appState Down, .. })
+    (VtyEvent (Vty.EvResize _ _)) -> put st
+    (VtyEvent (Vty.EvKey Vty.KUp _)) ->
+      put BrickState{ appState = moveCursor 1 appState Up, .. }
+    (VtyEvent (Vty.EvKey Vty.KDown _)) ->
+      put BrickState{ appState = moveCursor 1 appState Down, .. }
     (VtyEvent (Vty.EvKey key _)) ->
       case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
-        Nothing -> pure ()
-        Just (_, _, handler) -> handler
-    _ -> pure ()
+        Nothing -> put st
+        Just (_, _, handler) -> handler st
+    _ -> put st
 
 
-moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
-moveCursor steps direction ais@BrickInternalState{..} =
-  let newIx = if direction == Down then _ix + steps else _ix - steps
-  in  case _clr !? newIx of
-        Just _  -> ais & ix .~ newIx
+moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
+moveCursor steps ais@BrickInternalState{..} direction =
+  let newIx = if direction == Down then ix + steps else ix - steps
+  in  case clr !? newIx of
+        Just _  -> BrickInternalState { ix = newIx, .. }
         Nothing -> ais
 
 
 -- | 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 :: Ord n
-             => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
+             => (BrickState
+                 -> (Int, ListResult)
+                 -> ReaderT AppState IO (Either String a))
+             -> BrickState
              -> EventM n BrickState ()
-withIOAction action = do
-  as <- get
-  case listSelectedElement' (view appState as) of
-    Nothing      -> pure ()
-    Just (curr_ix, e) -> do
-      suspendAndResume $ do
-        settings <- readIORef settings'
-        flip runReaderT settings $ action (curr_ix, e) >>= \case
-          Left  err -> liftIO $ putStrLn ("Error: " <> err)
-          Right _   -> liftIO $ putStrLn "Success"
-        getAppData Nothing >>= \case
-          Right data' -> do
-            putStrLn "Press enter to continue"
-            _ <- getLine
-            pure (updateList data' as)
-          Left err -> throwIO $ userError err
+withIOAction action as = case listSelectedElement' (appState as) of
+  Nothing      -> put as
+  Just (ix, e) -> do
+    suspendAndResume $ do
+      settings <- readIORef settings'
+      flip runReaderT settings $ action as (ix, e) >>= \case
+        Left  err -> liftIO $ putStrLn ("Error: " <> err)
+        Right _   -> liftIO $ putStrLn "Success"
+      getAppData Nothing >>= \case
+        Right data' -> do
+          putStrLn "Press enter to continue"
+          _ <- getLine
+          pure (updateList data' as)
+        Left err -> throwIO $ userError err
 
 
 -- | Update app data and list internal state based on new evidence.
@@ -381,11 +369,11 @@ withIOAction action = do
 -- and @BrickSettings@.
 updateList :: BrickData -> BrickState -> BrickState
 updateList appD BrickState{..} =
-  let newInternalState = constructList appD _appSettings (Just _appState)
-  in  BrickState { _appState    = newInternalState
-                 , _appData     = appD
-                 , _appSettings = _appSettings
-                 , _appKeys     = _appKeys
+  let newInternalState = constructList appD appSettings (Just appState)
+  in  BrickState { appState    = newInternalState
+                 , appData     = appD
+                 , appSettings = appSettings
+                 , appKeys     = appKeys
                  }
 
 
@@ -394,12 +382,12 @@ constructList :: BrickData
               -> Maybe BrickInternalState
               -> BrickInternalState
 constructList appD appSettings =
-  replaceLR (filterVisible (_showAllVersions appSettings)
-                           (_showAllTools appSettings))
-            (_lr appD)
+  replaceLR (filterVisible (showAllVersions appSettings)
+                           (showAllTools appSettings))
+            (lr appD)
 
 listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
-listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix
+listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
 
 
 selectLatest :: Vector ListResult -> Int
@@ -445,9 +433,10 @@ filterVisible v t e | lInstalled e = True
 
 
 install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-         => (Int, ListResult)
+         => BrickState
+         -> (Int, ListResult)
          -> m (Either String ())
-install' (_, ListResult {..}) = do
+install' _ (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run =
@@ -521,9 +510,10 @@ install' (_, ListResult {..}) = do
 
 
 set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => (Int, ListResult)
+     => BrickState
+     -> (Int, ListResult)
      -> m (Either String ())
-set' input@(_, ListResult {..}) = do
+set' bs input@(_, ListResult {..}) = do
   settings <- liftIO $ readIORef settings'
 
   let run =
@@ -545,12 +535,12 @@ set' input@(_, ListResult {..}) = do
               promptAnswer <- getUserPromptResponse userPrompt
               case promptAnswer of
                 PromptYes -> do
-                  res <- install' input
+                  res <- install' bs input
                   case res of
                     (Left err) -> pure $ Left err
                     (Right _) -> do
                       logInfo "Setting now..."
-                      set' input
+                      set' bs input
 
                 PromptNo -> pure $ Left (prettyHFError e)
               where
@@ -565,9 +555,10 @@ set' input@(_, ListResult {..}) = do
 
 
 del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => (Int, ListResult)
+     => BrickState
+     -> (Int, ListResult)
      -> m (Either String ())
-del' (_, ListResult {..}) = do
+del' _ (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run = runE @'[NotInstalled, UninstallFailed]
@@ -591,9 +582,10 @@ del' (_, ListResult {..}) = do
 
 
 changelog' :: (MonadReader AppState m, MonadIO m)
-           => (Int, ListResult)
+           => BrickState
+           -> (Int, ListResult)
            -> m (Either String ())
-changelog' (_, ListResult {..}) = do
+changelog' _ (_, ListResult {..}) = do
   AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
   case getChangeLog dls lTool (ToolVersion lVer) of
     Nothing -> pure $ Left $
@@ -626,6 +618,7 @@ settings' = unsafePerformIO $ do
                       loggerConfig
 
 
+
 brickMain :: AppState
           -> IO ()
 brickMain s = do
@@ -649,7 +642,7 @@ brickMain s = do
 
 
 defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
+defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
 
 
 getGHCupInfo :: IO (Either String GHCupInfo)
@@ -676,4 +669,3 @@ getAppData mgi = runExceptT $ do
   flip runReaderT settings $ do
     lV <- listVersions Nothing [] False True (Nothing, Nothing)
     pure $ BrickData (reverse lV)
-

docs/install.md

@@ -38,78 +38,49 @@ Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information
 
 ### Linux Debian
 
-#### Generic
-
 The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
 
-#### Version >= 11
-
-The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
 ### Linux Ubuntu
 
-#### Generic
-
 The following distro packages are required: `build-essential curl libffi-dev libffi6 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
 
-#### Version >= 20.04 && < 20.10
-
-The following distro packages are required: `build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
-#### Version >= 20.10
-
-The following distro packages are required: `build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5`
-
-
 ### Linux Fedora
 
-#### Generic
-
 The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
 
+### Linux Mageia
+
+The following distro packages are required: `curl gcc gcc-c++ gmp libffi-devel libffi7 libgmp-devel libgmp10 make libncurses-devel libncurses5 xz perl`
 
 ### Linux CentOS
 
-#### Generic
-
 The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses ncurses-compat-libs xz perl`
 
-#### Version >= 7 && < 8
-
-The following distro packages are required: `gcc gcc-c++ gmp gmp-devel make ncurses xz perl`
-
-
 ### Linux Alpine
 
-#### Generic
-
 The following distro packages are required: `binutils-gold curl gcc g++ gmp-dev libc-dev libffi-dev make musl-dev ncurses-dev perl tar xz`
 
+### Linux VoidLinux
+
+The following distro packages are required: `gcc gmp curl coreutils xz ncurses make ncurses-libtinfo-libs perl tar`
 
 ### Linux (generic)
 
-#### Generic
-
 You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.
 
 ### Darwin
 
-#### Generic
-
 On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again.
 On Darwin M1 you might also need a working llvm installed (e.g. via brew) and have the toolchain exposed in PATH.
 
 ### FreeBSD
 
-#### Generic
-
 The following distro packages are required: `curl gcc gmp gmake ncurses perl5 libffi libiconv`
 
+Notice that only FreeBSD 13.x is supported. If the installation fails, complaining about `libncursesw.8.so`, you will need to install FreeBSD 12 compat package first, for example, `pkg install misc/compat12x`.
 
 ### Windows
 
-#### Generic
-
 On Windows, msys2 should already have been set up during the installation, so most users should just proceed. If you are installing manually, make sure to have a working mingw64 toolchain and shell.
 
 ## Next steps

ghcup.cabal

@@ -352,9 +352,6 @@ executable ghcup
       , transformers  ^>=0.5
       , unix          ^>=2.7
       , vty           ^>=5.37
-      , microlens     ^>=0.4.13
-      , microlens-th  ^>=0.4.3
-      , microlens-mtl ^>=0.2.0
 
   if os(windows)
     cpp-options: -DIS_WINDOWS

lib/GHCup/Utils.hs

@@ -369,7 +369,9 @@ cabalSet = do
   handleIO' NoSuchThing (\_ -> pure Nothing) $ do
     broken <- liftIO $ isBrokenSymlink cabalbin
     if broken
-      then pure Nothing
+      then do
+        logWarn $ "Broken symlink at " <> T.pack cabalbin
+        pure Nothing
       else do
         link <- liftIO
           $ handleIO' InvalidArgument
@@ -466,7 +468,9 @@ stackSet = do
   handleIO' NoSuchThing (\_ -> pure Nothing) $ do
     broken <- liftIO $ isBrokenSymlink stackBin
     if broken
-      then pure Nothing
+      then do
+        logWarn $ "Broken symlink at " <> T.pack stackBin
+        pure Nothing
       else do
         link <- liftIO
           $ handleIO' InvalidArgument
@@ -520,15 +524,17 @@ isLegacyHLS ver = do
 
 
 -- Return the currently set hls version, if any.
-hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
+hlsSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
 hlsSet = do
   Dirs {..}  <- getDirs
   let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
 
-  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    broken <- isBrokenSymlink hlsBin
+  handleIO' NoSuchThing (\_ -> pure Nothing) $ do
+    broken <- liftIO $ isBrokenSymlink hlsBin
     if broken
-      then pure Nothing
+      then do
+        logWarn $ "Broken symlink at " <> T.pack hlsBin
+        pure Nothing
       else do
         link <- liftIO $ getLinkTarget hlsBin
         Just <$> linkVersion link
@@ -556,6 +562,7 @@ hlsSet = do
 -- | Return the GHC versions the currently selected HLS supports.
 hlsGHCVersions :: ( MonadReader env m
                   , HasDirs env
+                  , HasLog env
                   , MonadIO m
                   , MonadThrow m
                   , MonadCatch m