Use MonadState Instance to simplify install', del', set' and changelog'. Lensify the app

fixes #777

app/ghcup/BrickMain.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module BrickMain where
 
@@ -25,6 +26,7 @@ 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
@@ -41,11 +43,11 @@ import           Data.Bool
 import           Data.Functor
 import           Data.List
 import           Data.Maybe
-import           Data.IORef
+import           Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
 import           Data.Vector                    ( Vector
                                                 , (!?)
                                                 )
-import           Data.Versions           hiding ( str )
+import           Data.Versions           hiding ( str, Lens' )
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( appendFile )
 import           System.FilePath
@@ -61,68 +63,84 @@ 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 = [] 
 
-
 data BrickData = BrickData
-  { lr    :: [ListResult]
+  { _lr    :: [ListResult]
   }
   deriving Show
 
+makeLenses ''BrickData
+
 data BrickSettings = BrickSettings
-  { showAllVersions    :: Bool
+  { _showAllVersions    :: Bool
-  , showAllTools       :: Bool
+  , _showAllTools       :: Bool
   }
-  deriving Show
+  --deriving Show
+
+makeLenses ''BrickSettings
 
 data BrickInternalState = BrickInternalState
-  { clr :: Vector ListResult
+  { _clr   :: Vector ListResult
-  , ix  :: Int
+  , _ix    :: Int
   }
-  deriving Show
+  --deriving Show
+
+makeLenses ''BrickInternalState
 
 data BrickState = BrickState
-  { appData     :: BrickData
+  { _appData     :: BrickData
-  , appSettings :: BrickSettings
+  , _appSettings :: BrickSettings
-  , appState    :: BrickInternalState
+  , _appState    :: BrickInternalState
-  , appKeys     :: KeyBindings
+  , _appKeys     :: KeyBindings
   }
-  deriving Show
+  --deriving Show
 
+makeLenses ''BrickState
 
 keyHandlers :: KeyBindings
             -> [ ( Vty.Key
                  , BrickSettings -> String
-                 , BrickState -> EventM String 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"
+       if _showAllVersions then "Don't show all versions" else "Show all versions"
-    , hideShowHandler (not . showAllVersions) showAllTools
+    , hideShowHandler' (not . _showAllVersions) _showAllTools
     )
   , ( bShowAllTools
     , \BrickSettings {..} ->
-       if showAllTools then "Don't show all tools" else "Show all tools"
+       if _showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler showAllVersions (not . showAllTools)
+    , hideShowHandler' _showAllVersions (not . _showAllTools)
     )
-  , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
+  , (bUp, const "Up", appState %= moveCursor 1 Up)
-  , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
+  , (bDown, const "Down", appState %= moveCursor 1 Down)
   ]
  where
-  hideShowHandler f p BrickState{..} =
+  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
-    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+  hideShowHandler' f p = do 
-        newInternalState = constructList appData newAppSettings (Just appState)
+    app_settings <- use appSettings
-    in  put (BrickState appData newAppSettings newInternalState appKeys)
+    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)
+
 
 
 showKey :: Vty.Key -> String
@@ -131,13 +149,12 @@ 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
 
@@ -148,7 +165,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")
@@ -156,8 +173,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
+    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
+        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
@@ -263,11 +280,10 @@ 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]
+  App { appDraw     = \st -> [ui dimAttrs st]
-  , appHandleEvent  = \be -> get >>= \s -> eventHandler s be
+  , appHandleEvent  = eventHandler
   , appStartEvent   = return ()
   , appAttrMap      = const attrs
   , appChooseCursor = showFirstCursor
@@ -292,6 +308,7 @@ 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
@@ -312,56 +329,51 @@ dimAttributes no_color = attrMap
     withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
                   | otherwise = Vty.withBackColor
 
-eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
+eventHandler :: BrickEvent String e -> EventM String BrickState ()
-eventHandler st@BrickState{..} ev = do
+eventHandler ev = do
   AppState { keyBindings = kb } <- liftIO $ readIORef settings'
   case ev of
-    (MouseDown _ Vty.BScrollUp _ _) ->
+    (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
-      put (BrickState { appState = moveCursor 1 appState Up, .. })
+    (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
-    (MouseDown _ Vty.BScrollDown _ _) ->
+    (VtyEvent (Vty.EvResize _ _)) -> pure ()
-      put (BrickState { appState = moveCursor 1 appState Down, .. })
+    (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
-    (VtyEvent (Vty.EvResize _ _)) -> put st
+    (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
-    (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 -> put st
+        Nothing -> pure ()
-        Just (_, _, handler) -> handler st
+        Just (_, _, handler) -> handler
-    _ -> put st
+    _ -> pure ()
 
 
-moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
+moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
-moveCursor steps ais@BrickInternalState{..} direction =
+moveCursor steps direction ais@BrickInternalState{..} =
-  let newIx = if direction == Down then ix + steps else ix - steps
+  let newIx = if direction == Down then _ix + steps else _ix - steps
-  in  case clr !? newIx of
+  in  case _clr !? newIx of
-        Just _  -> BrickInternalState { ix = newIx, .. }
+        Just _  -> ais & 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
-             => (BrickState
+             => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
-                 -> (Int, ListResult)
-                 -> ReaderT AppState IO (Either String a))
-             -> BrickState
              -> EventM n BrickState ()
-withIOAction action as = case listSelectedElement' (appState as) of
+withIOAction action = do
-  Nothing      -> put as
+  as <- get
-  Just (ix, e) -> do
+  case listSelectedElement' (view appState as) of
-    suspendAndResume $ do
+    Nothing      -> pure ()
-      settings <- readIORef settings'
+    Just (curr_ix, e) -> do
-      flip runReaderT settings $ action as (ix, e) >>= \case
+      suspendAndResume $ do
-        Left  err -> liftIO $ putStrLn ("Error: " <> err)
+        settings <- readIORef settings'
-        Right _   -> liftIO $ putStrLn "Success"
+        flip runReaderT settings $ action (curr_ix, e) >>= \case
-      getAppData Nothing >>= \case
+          Left  err -> liftIO $ putStrLn ("Error: " <> err)
-        Right data' -> do
+          Right _   -> liftIO $ putStrLn "Success"
-          putStrLn "Press enter to continue"
+        getAppData Nothing >>= \case
-          _ <- getLine
+          Right data' -> do
-          pure (updateList data' as)
+            putStrLn "Press enter to continue"
-        Left err -> throwIO $ userError err
+            _ <- getLine
+            pure (updateList data' as)
+          Left err -> throwIO $ userError err
 
 
 -- | Update app data and list internal state based on new evidence.
@@ -369,11 +381,11 @@ withIOAction action as = case listSelectedElement' (appState as) of
 -- and @BrickSettings@.
 updateList :: BrickData -> BrickState -> BrickState
 updateList appD BrickState{..} =
-  let newInternalState = constructList appD appSettings (Just appState)
+  let newInternalState = constructList appD _appSettings (Just _appState)
-  in  BrickState { appState    = newInternalState
+  in  BrickState { _appState    = newInternalState
-                 , appData     = appD
+                 , _appData     = appD
-                 , appSettings = appSettings
+                 , _appSettings = _appSettings
-                 , appKeys     = appKeys
+                 , _appKeys     = _appKeys
                  }
 
 
@@ -382,12 +394,12 @@ constructList :: BrickData
               -> Maybe BrickInternalState
               -> BrickInternalState
 constructList appD appSettings =
-  replaceLR (filterVisible (showAllVersions appSettings)
+  replaceLR (filterVisible (_showAllVersions appSettings)
-                           (showAllTools appSettings))
+                           (_showAllTools appSettings))
-            (lr appD)
+            (_lr appD)
 
 listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
-listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
+listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix
 
 
 selectLatest :: Vector ListResult -> Int
@@ -433,10 +445,9 @@ filterVisible v t e | lInstalled e = True
 
 
 install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-         => BrickState
+         => (Int, ListResult)
-         -> (Int, ListResult)
          -> m (Either String ())
-install' _ (_, ListResult {..}) = do
+install' (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run =
@@ -510,10 +521,9 @@ install' _ (_, ListResult {..}) = do
 
 
 set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => BrickState
+     => (Int, ListResult)
-     -> (Int, ListResult)
      -> m (Either String ())
-set' bs input@(_, ListResult {..}) = do
+set' input@(_, ListResult {..}) = do
   settings <- liftIO $ readIORef settings'
 
   let run =
@@ -535,12 +545,12 @@ set' bs input@(_, ListResult {..}) = do
               promptAnswer <- getUserPromptResponse userPrompt
               case promptAnswer of
                 PromptYes -> do
-                  res <- install' bs input
+                  res <- install' input
                   case res of
                     (Left err) -> pure $ Left err
                     (Right _) -> do
                       logInfo "Setting now..."
-                      set' bs input
+                      set' input
 
                 PromptNo -> pure $ Left (prettyHFError e)
               where
@@ -555,10 +565,9 @@ set' bs input@(_, ListResult {..}) = do
 
 
 del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => BrickState
+     => (Int, ListResult)
-     -> (Int, ListResult)
      -> m (Either String ())
-del' _ (_, ListResult {..}) = do
+del' (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 
   let run = runE @'[NotInstalled, UninstallFailed]
@@ -582,10 +591,9 @@ del' _ (_, ListResult {..}) = do
 
 
 changelog' :: (MonadReader AppState m, MonadIO m)
-           => BrickState
+           => (Int, ListResult)
-           -> (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 $
@@ -618,7 +626,6 @@ settings' = unsafePerformIO $ do
                       loggerConfig
 
 
-
 brickMain :: AppState
           -> IO ()
 brickMain s = do
@@ -642,7 +649,7 @@ brickMain s = do
 
 
 defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
+defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
 
 
 getGHCupInfo :: IO (Either String GHCupInfo)
@@ -669,3 +676,4 @@ getAppData mgi = runExceptT $ do
   flip runReaderT settings $ do
     lV <- listVersions Nothing [] False True (Nothing, Nothing)
     pure $ BrickData (reverse lV)
+

docs/install.md

@@ -38,49 +38,78 @@ 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,6 +352,9 @@ 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