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
+  { 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
-                 , 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"
+       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", appState %= moveCursor 1 Up)
+  , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
-  , (bDown, const "Down", appState %= moveCursor 1 Down)
+  , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
   ]
  where
-  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
+  hideShowHandler f p BrickState{..} =
-  hideShowHandler' f p = do 
+    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
-    app_settings <- use appSettings
+        newInternalState = constructList appData newAppSettings (Just appState)
-    let 
+    in  put (BrickState appData newAppSettings newInternalState appKeys)
-      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
@@ -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
+    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
@@ -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]
+  App { appDraw         = \st -> [ui dimAttrs st]
-  , appHandleEvent  = eventHandler
+  , 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 :: BrickState -> BrickEvent String e -> EventM String BrickState ()
-eventHandler ev = do
+eventHandler st@BrickState{..} ev = do
   AppState { keyBindings = kb } <- liftIO $ readIORef settings'
   case ev of
-    (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
+    (MouseDown _ Vty.BScrollUp _ _) ->
-    (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
+      put (BrickState { appState = moveCursor 1 appState Up, .. })
-    (VtyEvent (Vty.EvResize _ _)) -> pure ()
+    (MouseDown _ Vty.BScrollDown _ _) ->
-    (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
+      put (BrickState { appState = moveCursor 1 appState Down, .. })
-    (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 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 ()
+        Nothing -> put st
-        Just (_, _, handler) -> handler
+        Just (_, _, handler) -> handler st
-    _ -> pure ()
+    _ -> put st
 
 
-moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
+moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
-moveCursor steps direction ais@BrickInternalState{..} =
+moveCursor steps ais@BrickInternalState{..} direction =
-  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 _  -> ais & ix .~ newIx
+        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
+withIOAction action as = case listSelectedElement' (appState as) of
-  as <- get
+  Nothing      -> put as
-  case listSelectedElement' (view appState as) of
+  Just (ix, e) -> do
-    Nothing      -> pure ()
+    suspendAndResume $ do
-    Just (curr_ix, e) -> do
+      settings <- readIORef settings'
-      suspendAndResume $ do
+      flip runReaderT settings $ action as (ix, e) >>= \case
-        settings <- readIORef settings'
+        Left  err -> liftIO $ putStrLn ("Error: " <> err)
-        flip runReaderT settings $ action (curr_ix, e) >>= \case
+        Right _   -> liftIO $ putStrLn "Success"
-          Left  err -> liftIO $ putStrLn ("Error: " <> err)
+      getAppData Nothing >>= \case
-          Right _   -> liftIO $ putStrLn "Success"
+        Right data' -> do
-        getAppData Nothing >>= \case
+          putStrLn "Press enter to continue"
-          Right data' -> do
+          _ <- getLine
-            putStrLn "Press enter to continue"
+          pure (updateList data' as)
-            _ <- getLine
+        Left err -> throwIO $ userError err
-            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)
+  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
                  }
 
 
@@ -394,12 +382,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
@@ -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)
-

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