More work

app/ghcup/AnsiMain.hs

@@ -14,10 +14,15 @@ import           GHCup.Prelude                  ( decUTF8Safe )
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.Process
+import           GHCup.Prompts
 import           GHCup.Types             hiding ( LeanAppState(..) )
 import           GHCup.Types.Optics             ( getDirs )
 import           GHCup.Utils
 
+import           Data.List (sort, intersperse)
+import           Data.Versions (prettyPVP)
+import           Data.Maybe (catMaybes)
+import           Codec.Archive
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Except
 -- import           System.Console.ANSI
@@ -27,9 +32,13 @@ import           System.Console.ANSI.Types
 import           Terminal.Game
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
-import           Control.Monad                  ( join, when )
+import           Control.Exception.Safe
+import           Control.Monad                  ( join, when, void, forM_ )
 import           Control.Monad.ST
-import           Control.Monad.Reader           ( ReaderT(runReaderT) )
+import           Control.Monad.Reader           ( ReaderT(runReaderT), MonadReader, ask, lift )
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Resource
+import           Data.Functor
 import           Data.Bifunctor
 import           Data.STRef
 import           Data.IORef
@@ -40,7 +49,15 @@ import qualified Data.Vector                   as V
 import           GHC.IO                         ( unsafePerformIO )
 import           Haskus.Utils.Variant.Excepts
 import           System.Exit
+import System.Environment (getExecutablePath)
 import Data.Versions (prettyVer)
+import qualified Data.Text                     as T
+import qualified Data.Text.Lazy.Builder        as B
+import qualified Data.Text.Lazy                as L
+import System.FilePath
+import URI.ByteString (serializeURIRef')
+
+
 
 data Direction = Up
                | Down
@@ -69,10 +86,22 @@ data BrickState = BrickState
   , appState     :: BrickInternalState
   , appKeys      :: KeyBindings
   , appQuit      :: Bool
+  , appRestart   :: Bool
   , appMoreInput :: Maybe String
   }
   deriving Show
 
+
+startGame :: BrickState -> IO BrickState
+startGame g = do
+  g'@BrickState { appRestart } <- errorPress $ playGameT liftIO (ghcupGame g)
+  if appRestart
+  then do
+    putStrLn "Press enter to continue"
+    _ <- getLine
+    startGame $ g' { appRestart = False }
+  else pure g'
+
 ansiMain :: AppState -> IO ()
 ansiMain s = do
   writeIORef settings' s
@@ -85,10 +114,12 @@ ansiMain s = do
                          (constructList ad defaultAppSettings Nothing)
                          (keyBindings (s :: AppState))
                          False
+                         False
                          Nothing
 
 
-      errorPress $ playGame (ghcupGame g)
+      void $ startGame g
+      cleanAndExit
     Left e -> do
       flip runReaderT s $ logError $ "Error building app state: " <> Tx.pack
         (show e)
@@ -105,37 +136,61 @@ ghcupGame bs = Game 13
                     bs                                    -- ticks per second
                     (\ge s e -> logicFun ge s e)          -- logic function
                     (\r s -> centerFull r $ drawFun s r)  -- draw function
-                    appQuit                             -- quit function
+                    (\bs -> appQuit bs || appRestart bs)  -- quit function
 
 
 drawFun :: BrickState -> GEnv -> Plane
 drawFun (BrickState {..}) GEnv{..} =
   blankPlane mw mh
     & (1, 1)   % box 1        1        '┌'
-    & (2, 1)   % box 1        (mh - 2) '│'
+    & (2, 1)   % box 1        (mh - 3) '│'
     & (1, 2)   % box (mw - 2) 1        '─'
-    & (2, mw)  % box 1        (mh - 2) '│'
+    & (2, mw)  % box 1        (mh - 3) '│'
     & (1, mw)  % box 1        1        '┐'
-    & (mh, 2)  % box (mw - 2) 1        '─'
+    & (mh-1, 2)  % box (mw - 2) 1        '─'
-    & (mh, 1)  % box 1        1        '└'
+    & (mh-1, 1)  % box 1        1        '└'
-    & (mh, mw) % box 1        1        '┘'
+    & (mh-1, mw) % box 1        1        '┘'
-    & (2, 2)   % box (mw - 2) (mh - 2) ' '
+    & (2, 2)   % box (mw - 2) (mh - 3) ' '
-    & (2, 2) % renderItems
+    & (2, 2)   % (header === box (mw - 2) 1 '─' === renderItems)
+    & (mh, 1)  % footer
+    & (1, mw `div` 2 - 2) % stringPlane "GHCup"
  where
   mh :: Height
   mw :: Width
   (mh, mw) = T.swap eTermDims
+  footer = hcat
+         . intersperse (stringPlane "  ")
+         . fmap stringPlane
+         $ ["q:Quit", "i:Install", "u:Uninstall", "s:Set", "c:Changelog", "a:all versions", "↑:Up", "↓:Down"]
+  header = hcat
+         . intersperse space
+         . fmap stringPlane
+         $ ["Tool", "Version", "Tags", "Notes"]
   renderItems = drawListElements renderItem True appState
-  renderItem _ b ListResult{..} =
+  renderItem _ b listResult@ListResult{..} =
     let marks = if
-          | lSet       -> (stringPlane "✔✔")
+          | lSet       -> color Green Vivid (stringPlane "✔✔")
-          | lInstalled -> (stringPlane "✓ ")
+          | lInstalled -> color Green Dull (stringPlane "✓ ")
-          | otherwise  -> (stringPlane "✗ ")
+          | otherwise  -> color Red Vivid (stringPlane "✗ ")
         ver = case lCross of
           Nothing -> stringPlane . Tx.unpack . prettyVer $ lVer
           Just c  -> stringPlane . Tx.unpack $ (c <> "-" <> prettyVer lVer)
         tool = printTool lTool
-    in marks ||| space ||| space ||| tool ||| space ||| ver
+        tag = let l = catMaybes . fmap printTag $ sort lTag
+              in  if null l then blankPlane 1 1 else foldr1 (\x y -> x ||| stringPlane "," ||| y) l
+        notes = let n = printNotes listResult
+                in  if null n
+                      then blankPlane 1 1
+                      else foldr1 (\x y -> x ||| stringPlane "," ||| y) n
+
+    in hcat [marks, space, space, tool, space, ver, space, tag, space, notes]
+
+  printTag Recommended    = Just $ color Green Dull $ stringPlane "recommended"
+  printTag Latest         = Just $ color Yellow Dull $ stringPlane "latest"
+  printTag Prerelease     = Just $ color Red Dull $ stringPlane "prerelease"
+  printTag (Base pvp'')   = Just $ stringPlane ("base-" ++ T.unpack (prettyPVP pvp''))
+  printTag Old            = Nothing
+  printTag (UnknownTag t) = Just $ stringPlane t
 
   printTool Cabal = stringPlane "cabal"
   printTool GHC   = stringPlane "GHC"
@@ -143,6 +198,12 @@ drawFun (BrickState {..}) GEnv{..} =
   printTool HLS   = stringPlane "HLS"
   printTool Stack = stringPlane "Stack"
 
+  printNotes ListResult {..} =
+    (if hlsPowered then [color Green Dull $ stringPlane "hls-powered"] else mempty
+      )
+      ++ (if fromSrc then [color Blue Dull $ stringPlane "compiled"] else mempty)
+      ++ (if lStray then [color Blue Dull $ stringPlane "stray"] else mempty)
+
   space = stringPlane " "
 
   -- | Draws the list elements.
@@ -183,7 +244,7 @@ drawFun (BrickState {..}) GEnv{..} =
                       pure $ V.fromList [markSelected elemWidget]
             i <- readSTRef ref
             pure (arr, i)
-        in vcat $ V.toList (makeVisible drawnElements (mh - 2) selIx)
+        in vcat $ V.toList (makeVisible drawnElements (mh - 5) selIx)
    where
     makeVisible :: V.Vector Plane -> Height -> Maybe Int -> V.Vector Plane
     makeVisible listElements drawableHeight (Just ix) =
@@ -202,17 +263,55 @@ drawFun (BrickState {..}) GEnv{..} =
     hBorder = box (mw - 2) 1 '─'
 
 
-logicFun :: GEnv -> BrickState -> Event -> BrickState
+logicFun :: GEnv -> BrickState -> Event -> IO BrickState
-logicFun _ gs (KeyPress 'q') = gs { appQuit = True }
+logicFun _ gs (KeyPress 'q') = pure gs { appQuit = True }
-logicFun _ gs Tick           = gs
+logicFun _ gs Tick           = pure gs
-logicFun _ gs@BrickState{appMoreInput = Nothing} (KeyPress '\ESC') = gs { appMoreInput = Just "\ESC" }
+logicFun _ gs@BrickState{appMoreInput = Nothing} (KeyPress '\ESC') = pure gs { appMoreInput = Just "\ESC" }
-logicFun _ gs@BrickState{appMoreInput = Just "\ESC"} (KeyPress '[') = gs { appMoreInput = Just "\ESC[" }
+logicFun _ gs@BrickState{appMoreInput = Just "\ESC"} (KeyPress '[') = pure gs { appMoreInput = Just "\ESC[" }
 logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'A')
-  = gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up }
+  = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up }
 logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'B')
-  = gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down }
+  = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down }
-logicFun _ gs@BrickState{appMoreInput = Just _} _ = gs { appMoreInput = Nothing }
+logicFun _ gs@BrickState{appMoreInput = Just _} _ = pure gs { appMoreInput = Nothing }
-logicFun _ gs (KeyPress c)   = gs
+logicFun _ gs (KeyPress 'i') = do
+  bs <- withIOAction install' gs
+  pure bs { appRestart = True }
+logicFun _ gs (KeyPress 'u') = do
+  bs <- withIOAction del' gs
+  pure bs { appRestart = True }
+logicFun _ gs (KeyPress 's') = do
+  bs <- withIOAction set' gs
+  pure bs { appRestart = True }
+logicFun _ gs (KeyPress 'c') = do
+  bs <- withIOAction changelog' gs
+  pure bs { appRestart = True }
+logicFun _ gs (KeyPress 'a') = pure $ hideShowHandler (not . showAllVersions) showAllTools gs
+ where
+  hideShowHandler :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> BrickState -> BrickState
+  hideShowHandler f p BrickState{..} =
+    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+        newInternalState = constructList appData newAppSettings (Just appState)
+    in  BrickState appData newAppSettings newInternalState appKeys appQuit appRestart appMoreInput
+logicFun _ gs (KeyPress c) = pure gs
+
+withIOAction :: (BrickState
+                 -> (Int, ListResult)
+                 -> ReaderT AppState IO (Either String a))
+             -> BrickState
+             -> IO BrickState
+withIOAction action as = case listSelectedElement' (appState as) of
+  Nothing      -> pure as
+  Just (ix, e) -> do
+    clearScreen
+
+    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
+        pure (updateList data' as)
+      Left err -> throwIO $ userError err
 
 moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
 moveCursor steps ais@BrickInternalState{..} direction =
@@ -225,6 +324,20 @@ defaultAppSettings :: BrickSettings
 defaultAppSettings =
   BrickSettings { showAllVersions = False, showAllTools = False }
 
+-- | Update app data and list internal state based on new evidence.
+-- This synchronises @BrickInternalState@ with @BrickData@
+-- 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
+                 , appQuit     = appQuit
+                 , appRestart  = appRestart
+                 , appMoreInput = appMoreInput
+                 }
 
 constructList
   :: BrickData
@@ -282,6 +395,172 @@ listSelectedElement' BrickInternalState {..} = fmap (ix, ) $ clr V.!? ix
 boundaries :: (Coords, Coords)
 boundaries = ((1, 1), (24, 80))
 
+install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
+         => BrickState
+         -> (Int, ListResult)
+         -> m (Either String ())
+install' _ (_, ListResult {..}) = do
+  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
+
+  let run =
+        runResourceT
+          . runE
+            @'[ AlreadyInstalled
+              , ArchiveResult
+              , UnknownArchive
+              , FileDoesNotExistError
+              , CopyError
+              , NoDownload
+              , NotInstalled
+              , BuildFailed
+              , TagNotFound
+              , DigestError
+              , GPGError
+              , DownloadFailed
+              , DirNotEmpty
+              , NoUpdate
+              , TarDirDoesNotExist
+              , FileAlreadyExistsError
+              , ProcessError
+              , ToolShadowed
+              , UninstallFailed
+              , MergeFileTreeError
+              ]
+
+  run (do
+      ce <- liftIO $ fmap (either (const Nothing) Just) $
+        try @_ @SomeException $ getExecutablePath >>= canonicalizePath
+      dirs <- lift getDirs
+      case lTool of
+        GHC   -> do
+          let vi = getVersionInfo lVer GHC dls
+          liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
+        Cabal -> do
+          let vi = getVersionInfo lVer Cabal dls
+          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
+        GHCup -> do
+          let vi = snd <$> getLatest dls GHCup
+          liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
+        HLS   -> do
+          let vi = getVersionInfo lVer HLS dls
+          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
+        Stack -> do
+          let vi = getVersionInfo lVer Stack dls
+          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
+    )
+    >>= \case
+          VRight (vi, Dirs{..}, Just ce) -> do
+            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+            case lTool of
+              GHCup -> do
+                up <- liftIO $ fmap (either (const Nothing) Just)
+                  $ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
+                when ((normalise <$> up) == Just (normalise ce)) $
+                  -- TODO: track cli arguments of previous invocation
+                  void $ liftIO $ exec ce ["tui"] Nothing Nothing
+                logInfo "Please restart 'ghcup' for the changes to take effect"
+              _ -> pure ()
+            pure $ Right ()
+          VRight (vi, _, _) -> do
+            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+            logInfo "Please restart 'ghcup' for the changes to take effect"
+            pure $ Right ()
+          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
+          VLeft (V NoUpdate) -> pure $ Right ()
+          VLeft e -> pure $ Left $ prettyShow e <> "\n"
+            <> "Also check the logs in ~/.ghcup/logs"
+
+
+set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
+     => BrickState
+     -> (Int, ListResult)
+     -> m (Either String ())
+set' bs input@(_, ListResult {..}) = do
+  settings <- liftIO $ readIORef settings'
+
+  let run =
+        flip runReaderT settings
+          . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
+
+  run (do
+      case lTool of
+        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
+        Cabal -> liftE $ setCabal lVer $> ()
+        HLS   -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
+        Stack -> liftE $ setStack lVer $> ()
+        GHCup -> pure ()
+    )
+    >>= \case
+          VRight _ -> pure $ Right ()
+          VLeft  e -> case e of
+            (V (NotInstalled tool _)) -> do
+              promptAnswer <- getUserPromptResponse userPrompt
+              case promptAnswer of
+                PromptYes -> do
+                  res <- install' bs input
+                  case res of
+                    (Left err) -> pure $ Left err
+                    (Right _) -> do
+                      logInfo "Setting now..."
+                      set' bs input
+
+                PromptNo -> pure $ Left (prettyShow e)
+              where
+                userPrompt = L.toStrict . B.toLazyText . B.fromString $
+                  "This Version of "
+                  <> show tool
+                  <> " you are trying to set is not installed.\n"
+                  <> "Would you like to install it first? [Y/N]: "
+
+            _ -> pure $ Left (prettyShow e)
+
+
+
+del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
+     => BrickState
+     -> (Int, ListResult)
+     -> m (Either String ())
+del' _ (_, ListResult {..}) = do
+  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
+
+  let run = runE @'[NotInstalled, UninstallFailed]
+
+  run (do
+      let vi = getVersionInfo lVer lTool dls
+      case lTool of
+        GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
+        Cabal -> liftE $ rmCabalVer lVer $> vi
+        HLS   -> liftE $ rmHLSVer lVer $> vi
+        Stack -> liftE $ rmStackVer lVer $> vi
+        GHCup -> pure Nothing
+    )
+    >>= \case
+          VRight vi -> do
+            forM_ (_viPostRemove =<< vi) $ \msg ->
+              logInfo msg
+            pure $ Right ()
+          VLeft  e -> pure $ Left (prettyShow e)
+
+
+changelog' :: (MonadReader AppState m, MonadIO m)
+           => BrickState
+           -> (Int, ListResult)
+           -> m (Either String ())
+changelog' _ (_, ListResult {..}) = do
+  AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
+  case getChangeLog dls lTool (Left lVer) of
+    Nothing -> pure $ Left $
+      "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
+    Just uri -> do
+      let cmd = case _rPlatform pfreq of
+            Darwin  -> "open"
+            Linux _ -> "xdg-open"
+            FreeBSD -> "xdg-open"
+            Windows -> "start"
+      exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
+        Right _ -> pure $ Right ()
+        Left  e -> pure $ Left $ prettyShow e
+
 
 settings' :: IORef AppState
 {-# NOINLINE settings' #-}