Create brick tui wrt #24

2020-07-06 22:39:16 +02:00 · 2020-07-06 22:39:16 +02:00 · da94fa5f92
parent 35bf9b5ff2
commit da94fa5f92
9 changed files with 403 additions and 24 deletions
--- a/.gitlab/before_script/linux/alpine/install_deps.sh
+++ b/.gitlab/before_script/linux/alpine/install_deps.sh
@ -18,12 +18,14 @@ apk add --no-cache \
 	tar \
 	perl

-ln -s libncurses.so /usr/lib/libtinfo.so
-ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
+ln -sf libncurses.so /usr/lib/libtinfo.so
+ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6
+ln -sf libtinfow.so.6 /usr/lib/libtinfow.so
+
 if [ "${BIT}" = "32" ] ; then
-	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5 > ./ghcup-bin
 else
-	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5 > ./ghcup-bin
 fi
 chmod +x ghcup-bin
 ./ghcup-bin upgrade
@ -57,7 +59,8 @@ apk add --no-cache \
 	openssl-dev \
 	openssl-libs-static \
 	xz \
-	xz-dev
-
+	xz-dev \
+	ncurses-static

+ln -sf libncursesw.a /usr/lib/libtinfow.a

--- a/.gitlab/script/ghcup_release.sh
+++ b/.gitlab/script/ghcup_release.sh
@ -16,16 +16,24 @@ git describe
 ecabal update

 if [ "${OS}" = "LINUX" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
+	if [ "${BIT}" = "32" ] ; then
+		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
+	fi
 elif [ "${OS}" = "FREEBSD" ] ; then
 	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
 else
-	ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
+	ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
 fi

 mkdir out
 cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
 ver=$(./ghcup --numeric-version)
-strip -s ./ghcup
+if [ "${OS}" = "DARWIN" ] ; then
+	strip ./ghcup
+else
+	strip -s ./ghcup
+fi
 cp ghcup out/${ARTIFACT}-${ver}

--- a/.gitlab/script/ghcup_version.sh
+++ b/.gitlab/script/ghcup_version.sh
@ -21,9 +21,9 @@ git describe --always
 ecabal update

 if [ "${OS}" = "DARWIN" ] ; then
-	ecabal build -w ghc-${GHC_VERSION}
+	ecabal build -w ghc-${GHC_VERSION} -ftui
 else
-	ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
+	ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
 fi

 cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
--- a/3rdparty/libarchive/c/autoconf-linux/config.h
+++ b/3rdparty/libarchive/c/autoconf-linux/config.h
@ -260,7 +260,7 @@
 /* #undef HAVE_ACL_IS_TRIVIAL_NP */

 /* Define to 1 if you have the <acl/libacl.h> header file. */
-#define HAVE_ACL_LIBACL_H 1
+/* #undef HAVE_ACL_LIBACL_H */

 /* Define to 1 if the system has the type `acl_permset_t'. */
 /* #undef HAVE_ACL_PERMSET_T */
@ -453,6 +453,7 @@
 /* #undef HAVE_EXPAT_H */

 /* Define to 1 if you have the <ext2fs/ext2_fs.h> header file. */
+/* #undef HAVE_EXT2FS_EXT2_FS_H */

 /* Define to 1 if you have the `extattr_get_fd' function. */
 /* #undef HAVE_EXTATTR_GET_FD */
@ -605,7 +606,7 @@
 /* #undef HAVE_LCHFLAGS */

 /* Define to 1 if you have the `lchmod' function. */
-/* #undef HAVE_LCHMOD */
+#define HAVE_LCHMOD 1

 /* Define to 1 if you have the `lchown' function. */
 #define HAVE_LCHOWN 1
@ -1030,7 +1031,7 @@
 #define HAVE_STRUCT_TM_TM_GMTOFF 1

 /* Define to 1 if `__tm_gmtoff' is a member of `struct tm'. */
-/* #undef HAVE_STRUCT_TM___TM_GMTOFF */
+#define HAVE_STRUCT_TM___TM_GMTOFF 1

 /* Define to 1 if the system has the type `struct vfsconf'. */
 /* #undef HAVE_STRUCT_VFSCONF */
@ -1042,9 +1043,10 @@
 #define HAVE_SYMLINK 1

 /* Define to 1 if you have the <sys/acl.h> header file. */
+/* #undef HAVE_SYS_ACL_H */

 /* Define to 1 if you have the <sys/cdefs.h> header file. */
-#define HAVE_SYS_CDEFS_H 1
+/* #undef HAVE_SYS_CDEFS_H */

 /* Define to 1 if you have the <sys/dir.h> header file, and it defines `DIR'.
   */
@ -1202,7 +1204,7 @@
 #define HAVE_WMEMMOVE 1

 /* Define to 1 if you have a working EXT2_IOC_GETFLAGS */
-#define HAVE_WORKING_EXT2_IOC_GETFLAGS 1
+/* #undef HAVE_WORKING_EXT2_IOC_GETFLAGS */

 /* Define to 1 if you have a working FS_IOC_GETFLAGS */
 #define HAVE_WORKING_FS_IOC_GETFLAGS 1
@ -1289,7 +1291,7 @@
 #define STDC_HEADERS 1

 /* Define to 1 if strerror_r returns char *. */
-#define STRERROR_R_CHAR_P 1
+/* #undef STRERROR_R_CHAR_P */

 /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
 #define TIME_WITH_SYS_TIME 1
--- a/README.md
+++ b/README.md
@ -40,7 +40,13 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"

 See `ghcup --help`.

-Common use cases are:
+For the simple interactive TUI, run:
+
+```sh
+ghcup tui
+```
+
+For the full functionality via cli:

 ```sh
 # list available ghc/cabal versions
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@ -0,0 +1,318 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BrickMain where
+
+import           GHCup
+import           GHCup.Download
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils
+import           GHCup.Utils.File
+import           GHCup.Utils.Logger
+
+import           Brick
+import           Brick.Widgets.Border
+import           Brick.Widgets.Border.Style
+import           Brick.Widgets.Center
+import           Brick.Widgets.List
+import           Codec.Archive
+import           Control.Exception.Safe
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+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
+import           Data.Vector                    ( Vector )
+import           Data.Versions           hiding ( str )
+import           Haskus.Utils.Variant.Excepts
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           System.IO.Unsafe
+import           URI.ByteString
+
+import qualified Data.Text                     as T
+import qualified Graphics.Vty                  as Vty
+import qualified Data.Vector                   as V
+
+
+data AppState = AppState {
+    lr :: LR
+  , dls :: GHCupDownloads
+}
+
+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
+    $ ( withBorderStyle unicode
+      $ borderWithLabel (str "GHCup")
+      $ (center $ renderList renderItem True lr)
+      )
+    )
+    <=> ( withAttr "help"
+        $ foldr1 (\x y -> x <+> str "  " <+> y)
+        . (++ [str "↑↓:Navigation"])
+        $ (fmap (\(c, s, _) -> str (c : ':' : s)) keyHandlers)
+        )
+
+ where
+  renderItem b ListResult {..} =
+    let marks = if
+          | lSet       -> (withAttr "set" $ str "✔✔")
+          | lInstalled -> (withAttr "installed" $ str "✓ ")
+          | otherwise  -> (withAttr "not-installed" $ str "✗ ")
+        ver = case lCross of
+          Nothing -> T.unpack . prettyVer $ lVer
+          Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
+    in  (   marks
+        <+> ( padLeft (Pad 2)
+            $ minHSize 20
+            $ (withAttr
+                (bool "inactive" "active" b)
+                (str $ (fmap toLower . show $ lTool) <> " " <> ver)
+              )
+            )
+        <+> (padLeft (Pad 1) $ if null lTag
+              then emptyWidget
+              else
+                foldr1 (\x y -> x <+> str "," <+> y)
+                  $ (fmap printTag $ sort lTag)
+            )
+        )
+
+  printTag Recommended        = withAttr "recommended" $ str "recommended"
+  printTag Latest             = withAttr "latest" $ str "latest"
+  printTag (Base       pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
+  printTag (UnknownTag t    ) = str t
+
+
+minHSize :: Int -> Widget n -> Widget n
+minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
+
+
+app :: App AppState e String
+app = App { appDraw         = \st -> [ui st]
+          , appHandleEvent  = eventHandler
+          , appStartEvent   = return
+          , appAttrMap      = const theMap
+          , appChooseCursor = neverShowCursor
+          }
+ where
+  theMap = attrMap
+    Vty.defAttr
+    [ ("active"       , bg Vty.blue)
+    , ("not-installed", fg Vty.red)
+    , ("set"          , fg Vty.green)
+    , ("installed"    , fg Vty.green)
+    , ("recommended"  , fg Vty.green)
+    , ("latest"       , fg Vty.yellow)
+    , ("help"         , Vty.defAttr `Vty.withStyle` Vty.italic)
+    ]
+
+
+eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
+eventHandler st (VtyEvent (Vty.EvResize _               _)) = continue st
+eventHandler st (VtyEvent (Vty.EvKey    (Vty.KChar 'q') _)) = halt st
+eventHandler st (VtyEvent (Vty.EvKey    Vty.KEsc        _)) = halt st
+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 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
+        apps <- (fmap . fmap)
+          (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
+          getAppState
+        case apps of
+          Right nas -> do
+            putStrLn "Press enter to continue"
+            _ <- getLine
+            pure nas
+          Left err -> throwIO $ userError err
+
+
+install' :: AppState -> (Int, ListResult) -> IO (Either String ())
+install' AppState {..} (_, ListResult {..}) = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
+  let runLogger = myLoggerT l
+
+  let
+    run =
+      runLogger
+        . flip runReaderT settings
+        . runResourceT
+        . runE
+          @'[AlreadyInstalled, UnknownArchive, ArchiveResult, DistroNotFound, FileDoesNotExistError, CopyError, NoCompatibleArch, NoDownload, NotInstalled, NoCompatiblePlatform, BuildFailed, TagNotFound, DigestError, DownloadFailed, NoUpdate]
+
+  (run $ do
+      case lTool of
+        GHC   -> liftE $ installGHCBin dls lVer Nothing
+        Cabal -> liftE $ installCabalBin dls lVer Nothing
+        GHCup -> liftE $ upgradeGHCup dls Nothing False $> ()
+    )
+    >>= \case
+          VRight _                          -> pure $ Right ()
+          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
+          VLeft (V (BuildFailed _ e)) ->
+            pure $ Left [i|Build failed with #{e}|]
+          VLeft (V NoDownload) ->
+            pure $ Left [i|No available version for #{prettyVer lVer}|]
+          VLeft (V NoUpdate) -> pure $ Right ()
+          VLeft e -> pure $ Left [i|#{e}
+Also check the logs in ~/.ghcup/logs|]
+
+
+set' :: AppState -> (Int, ListResult) -> IO (Either String ())
+set' _ (_, ListResult {..}) = do
+  settings <- readIORef settings'
+  l        <- readIORef logger'
+  let runLogger = myLoggerT l
+
+  let run =
+        runLogger
+          . flip runReaderT settings
+          . runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
+
+  (run $ do
+      case lTool of
+        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
+        Cabal -> liftE $ setCabal lVer $> ()
+        GHCup -> pure ()
+    )
+    >>= \case
+          VRight _ -> pure $ Right ()
+          VLeft  e -> pure $ Left [i|#{e}|]
+
+
+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]
+
+  (run $ do
+      case lTool of
+        GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
+        Cabal -> liftE $ rmCabalVer lVer $> ()
+        GHCup -> pure ()
+    )
+    >>= \case
+          VRight _ -> pure $ Right ()
+          VLeft  e -> pure $ Left [i|#{e}|]
+
+
+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}|]
+    Just uri -> do
+      exec "xdg-open" True [serializeURIRef' uri] Nothing Nothing >>= \case
+        Right _ -> pure $ Right ()
+        Left  e -> pure $ Left [i|#{e}|]
+
+
+settings' :: IORef Settings
+{-# NOINLINE settings' #-}
+settings' = unsafePerformIO
+  (newIORef Settings { cache      = True
+                     , noVerify   = False
+                     , keepDirs   = Never
+                     , downloader = Curl
+                     }
+  )
+
+
+logger' :: IORef LoggerConfig
+{-# NOINLINE logger' #-}
+logger' = unsafePerformIO
+  (newIORef $ LoggerConfig { lcPrintDebug = False
+                           , colorOutter  = \_ -> pure ()
+                           , rawOutter    = \_ -> pure ()
+                           }
+  )
+
+
+brickMain :: Settings -> LoggerConfig -> IO ()
+brickMain s l = do
+  writeIORef settings' s
+  -- logger interpreter
+  writeIORef logger'   l
+  let runLogger = myLoggerT l
+
+  eApps <- getAppState
+  case eApps of
+    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
+  settings <- readIORef settings'
+  l        <- readIORef logger'
+  let runLogger = myLoggerT l
+
+  r <-
+    runLogger
+    . flip runReaderT settings
+    . runE
+      @'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
+    $ do
+        (GHCupInfo _ dls) <- liftE $ getDownloadsF GHCupURL
+
+        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}|]
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -10,6 +10,10 @@

 module Main where

+#if defined(BRICK)
+import           BrickMain                    ( brickMain )
+#endif
+
 import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
@ -95,6 +99,9 @@ data Command
  | Upgrade UpgradeOpts Bool
  | ToolRequirements
  | ChangeLog ChangeLogOptions
+#if defined(BRICK)
+  | Interactive
+#endif

 data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
                 | ToolTag Tag
@ -223,7 +230,20 @@ opts =
 com :: Parser Command
 com =
  subparser
+#if defined(BRICK)
      (  command
+          "tui"
+          (   (\_ -> Interactive)
+          <$> (info
+                helper
+                (  progDesc "Start the interactive GHCup UI"
+                )
+              )
+          )
+      <>  command
+#else
+      (  command
+#endif
          "install"
          (   Install
          <$> (info
@ -870,11 +890,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]

          -- logger interpreter
          logfile <- initGHCupFileLogging [rel|ghcup.log|]
-          let runLogger = myLoggerT LoggerConfig
+          let loggerConfig = LoggerConfig
                { lcPrintDebug = optVerbose
                , colorOutter  = B.hPut stderr
                , rawOutter    = appendFile logfile
                }
+          let runLogger = myLoggerT loggerConfig


          -------------------------
@ -910,7 +931,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                  @'[ FileDoesNotExistError
                    , NotInstalled
                    , TagNotFound
-                    , TagNotFound
                    ]

          let
@ -923,7 +943,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]

          let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]

-          let runRmGHC =
+          let runRm =
                runLogger . flip runReaderT settings . runE @'[NotInstalled]

          let runDebugInfo =
@ -1107,7 +1127,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                          pure $ ExitFailure 14

          let rmGHC' RmOptions{..} =
-                (runRmGHC $ do
+                (runRm $ do
                    liftE $ rmGHCVer ghcVer
                  )
                  >>= \case
@ -1117,7 +1137,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                          pure $ ExitFailure 7

          let rmCabal' tv =
-                (runSetCabal $ do
+                (runRm $ do
                    liftE $ rmCabalVer tv
                  )
                  >>= \case
@ -1129,6 +1149,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]


          res <- case optCommand of
+#if defined(BRICK)
+            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.|])
              installGHC iopts
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -21,6 +21,11 @@ source-repository head
  type:     git
  location: https://gitlab.haskell.org/haskell/ghcup-hs.git

+flag tui
+  description: Build the brick powered tui (ghcup tui)
+  default:     False
+  manual:      True
+
 flag internal-downloader
  description: Compile the internal downloader, which links against OpenSSL
  default:     False
@ -50,6 +55,9 @@ common base16-bytestring
 common binary
  build-depends: binary >=0.8.6.0

+common brick
+  build-depends: brick >=0.54
+
 common bytestring
  build-depends: bytestring >=0.10

@ -158,7 +166,6 @@ common string-interpolate
 common table-layout
  build-depends: table-layout >=0.8

-
 common template-haskell
  build-depends: template-haskell >=2.7

@ -198,6 +205,9 @@ common vector
 common versions
  build-depends: versions >=3.5

+common vty
+  build-depends: vty >=5.28.2
+
 common word8
  build-depends: word8 >=0.1.3

@ -350,6 +360,13 @@ executable ghcup
  if flag(internal-downloader)
    cpp-options:     -DINTERNAL_DOWNLOADER

+  if flag(tui)
+    import:
+      brick
+      , vector
+      , vty
+    other-modules: BrickMain
+    cpp-options:     -DBRICK

 executable ghcup-gen
  import:
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -927,6 +927,8 @@ upgradeGHCup dls mtarget force = do
          `unionFileModes` ownerExecuteMode
          `unionFileModes` groupExecuteMode
          `unionFileModes` otherExecuteMode
+  binDir <- liftIO $ ghcupBinDir
+  liftIO $ createDirIfMissing newDirPerms binDir
  case mtarget of
    Nothing -> do
      dest <- liftIO $ ghcupBinDir