Rework TUI

.github/scripts/cross.sh

@@ -94,7 +94,7 @@ done
 [ -z "${GHC_VER}" ] && GHC_VER=9.6.7
 [ -z "${GHC_TARGET_VERSION}" ] && GHC_TARGET_VERSION=8.10.7
 [ -z "${CABAL_VER}" ] && CABAL_VER=3.14.2.0
-[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.0.9
+[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.1.0
 [ -z "${WRAPPER}" ] && WRAPPER=run
 
 export GHCUP_INSTALL_BASE_PREFIX

.github/scripts/test.sh

@@ -89,7 +89,7 @@ done
 [ -z "${PROJECT_DIR}" ] && PROJECT_DIR=$(pwd)
 [ -z "${GHC_VER}" ] && GHC_VER=9.6.7
 [ -z "${CABAL_VER}" ] && CABAL_VER=3.14.2.0
-[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.0.9
+[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.1.0
 
 export GHCUP_INSTALL_BASE_PREFIX
 

.github/workflows/cross.yaml

@@ -21,15 +21,15 @@ env:
   CABAL_CACHE_NONFATAL: yes
   GHCUP_INSTALL_BASE_PREFIX: ${{ github.workspace }}
   GITHUB_WORKSPACE: ${{ github.workspace }}
-  GHCUP_VER: 0.2.0.0
+  GHCUP_VER: 0.2.1.0
 
 jobs:
   build:
     name: Build linux binary
     runs-on: ubuntu-latest
     env:
       CABAL_VER: 3.14.2.0
-      JSON_VERSION: "0.0.9"
+      JSON_VERSION: "0.1.0"
       AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
       AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
       S3_HOST: ${{ secrets.S3_HOST }}
@@ -74,7 +74,7 @@ jobs:
         CABAL_VER: 3.14.2.0
         BUILD_CONF_ARGS: "--enable-unregisterised"
         HADRIAN_FLAVOUR: ""
-        JSON_VERSION: "0.0.9"
+        JSON_VERSION: "0.1.0"
         GHC_VER: 8.10.6
         GHC_TARGET_VERSION: "8.10.7"
     steps:
@@ -127,7 +127,7 @@ jobs:
         CABAL_VER: 3.14.2.0
         BUILD_CONF_ARGS: ""
         HADRIAN_FLAVOUR: "default+native_bignum"
-        JSON_VERSION: "0.0.9"
+        JSON_VERSION: "0.1.0"
         GHC_VER: 9.6.7
         GHC_TARGET_VERSION: "9.6.7"
         WRAPPER: "emconfigure"

.github/workflows/release.yaml

@@ -19,10 +19,10 @@ concurrency:
 env:
   CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }}
   CABAL_CACHE_NONFATAL: yes
-  JSON_VERSION: "0.0.9"
+  JSON_VERSION: "0.1.0"
   GHC_VER: 9.6.7
   CABAL_VER: 3.14.2.0
-  GHCUP_VER: 0.2.0.0
+  GHCUP_VER: 0.2.1.0
   AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
   AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }}
   S3_HOST: ${{ secrets.S3_HOST }}

app/ghcup/Main.hs

@@ -65,6 +65,11 @@ import qualified Data.Text.Encoding as E
 import qualified Data.Text.IO       as T
 import qualified GHCup.Types        as Types
 
+#if defined(DHALL)
+import qualified Dhall
+import qualified Dhall.Core
+import qualified Data.Either.Validation as Validation
+#endif
 
 
 
@@ -326,6 +331,17 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             GC gcOpts                  -> gc gcOpts runAppState runLogger
             Run runCommand             -> run runCommand settings appState leanAppstate runLogger
             PrintAppErrors             -> putStrLn allHFError >> pure ExitSuccess
+#if defined(DHALL)
+            GenerateDhallSchema        ->
+              case Dhall.expected (Dhall.auto @GHCupInfo) of
+                  Validation.Success result -> do
+                    T.putStrLn (Dhall.Core.pretty result)
+                    pure ExitSuccess
+                  Validation.Failure errors -> do
+                    runLogger $ logError (T.pack $ show errors)
+                    pure $ ExitFailure 42
+#endif
+
 
           case res of
             ExitSuccess        -> pure ()

data/config.yaml

@@ -13,6 +13,21 @@ no-network: False
 # whether/how to do gpg verification
 gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
 
+# A wrapper around configure/make
+# Can be used to sandbox untrusted build systems, e.g.:
+#
+# build-wrapper: null
+#   cmd: bwrap
+#   cmdArgs:
+#     [ --ro-bind, /, /
+#     , --bind, /home/wurst/.ghcup, /home/wurst/.ghcup
+#     , --bind, /home/wurst/.cabal, /home/wurst/.cabal
+#     , --dev, /dev
+#     , --proc, /proc
+#     , --tmpfs, /tmp
+#     ]
+build-wrapper: null
+
 # TUI key bindings,
 # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
 # for possible values.

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.4
 name:               ghcup
-version:            0.2.0.0
+version:            0.2.1.0
 license:            LGPL-3.0-only
 license-file:       LICENSE
 copyright:          Julian Ospald 2024
@@ -95,6 +95,12 @@ common common-ghc-options
 common app-common-depends
   import: common-ghc-options
 
+  if flag(dhall)
+    cpp-options: -DDHALL
+    build-depends:
+        dhall  ^>=1.42
+      , either ^>=5.0.3
+
   build-depends:
     , aeson                  >=1.4
     , aeson-pretty           ^>=0.8.8
@@ -106,6 +112,7 @@ common app-common-depends
     , deepseq                ^>=1.4 || ^>=1.5 || ^>=1.6
     , directory              ^>=1.3.6.0
     , filepath               >=1.4.101.0
+    , indexed-traversable   ^>=0.1.4
     , variant                ^>=1.0
     , megaparsec             >=8.0.0    && <9.8
     , mtl                    ^>=2.2 || ^>=2.3
@@ -194,6 +201,7 @@ library
     GHCup.Prelude.Version.QQ
     GHCup.Query
     GHCup.Query.DB
+    GHCup.Query.DB.HLS
     GHCup.Query.GHCupDirs
     GHCup.Query.Metadata
     GHCup.Query.Symlink
@@ -211,6 +219,7 @@ library
     GHCup.Types.Stack
     GHCup.Types.Tar
     GHCup.Unpack
+    GHCup.Warnings
 
   hs-source-dirs:     lib
   other-modules:      Paths_ghcup
@@ -286,12 +295,6 @@ library
     , word8                 ^>=0.1.3
     , zlib                  ^>=0.6.2.2 || ^>=0.7
 
-  if flag(dhall)
-    cpp-options: -DDHALL
-    build-depends:
-      dhall  ^>=1.42
-
-
   if flag(yaml-streamly)
     build-depends:
         yaml-streamly ^>=0.12.5
@@ -409,7 +412,7 @@ library ghcup-tui
     GHCup.Brick.Widgets.Navigation
     GHCup.Brick.Widgets.Tutorial
     GHCup.Brick.Widgets.KeyInfo
-    GHCup.Brick.Widgets.SectionList
+    GHCup.Brick.Widgets.ToolInfo
     GHCup.Brick.Widgets.Menu
     GHCup.Brick.Widgets.Menus.Context
     GHCup.Brick.Widgets.Menus.AdvancedInstall

installer-dsl.md

@@ -1,12 +1,3 @@
-## documentation
-
-- configure script must support `--prefix`
-- make must support `DESTDIR`
-- write about the rewrite in the dev section
-- first tool in exe list matters
-- invariants (`make` must not compile the binaries that are to be installed)
-- limitations (packaging `cabal-cache`)
-
 ## breaking changes
 
 - `cabal install <ghc-ver>` is gone, use `cabal install ghc <ghc-ver>`
@@ -15,8 +6,6 @@
 
 ## refactoring and some day
 
-- get rid of Utils/Common... and improve module structure
-- rename GHCTargetVersion
 - better logging
 
 ## investigate
@@ -30,9 +19,7 @@
 
 ## code TODO
 
-- emit dhall types
-- TUI
-
+- test: make sure we can generate dhall and convert it back to yaml
 
 ## ideas
 

lib-opt/GHCup/OptParse.hs

@@ -115,6 +115,9 @@ data Command
   | GC GCOptions
   | Run RunOptions
   | PrintAppErrors
+#if defined(DHALL)
+  | GenerateDhallSchema
+#endif
 
 
 toVerbosity :: Maybe Bool -> Maybe Int
@@ -360,6 +363,15 @@ com =
                      (progDesc ""))
            <> internal
           )
+#if defined(DHALL)
+     <|> subparser
+          (command
+              "generate-dhall-schema"
+               (info (pure GenerateDhallSchema <**> helper)
+                     (progDesc ""))
+           <> internal
+          )
+#endif
 
 -- | Handle 'ParserResult'.
 handleParseResult' :: Maybe FilePath -> Bool -> ParserResult a -> IO a

lib-opt/GHCup/OptParse/Common.hs

@@ -326,7 +326,7 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
           runEnv = flip runReaderT appState . runE
 
       (VRight installedVersions) <- runEnv $ listVersions (Just [tool]) criteria False False (Nothing, Nothing)
-      return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
+      return $ fmap (T.unpack . prettyVer) . filter filter' . maybe [] (fmap lVer . snd) $ M.lookup tool installedVersions
 
 
 toolDlCompleter :: Tool -> Completer
@@ -481,8 +481,11 @@ checkForUpdates :: ( MonadReader env m
                 => m [(Tool, TargetVersion)]
 checkForUpdates = do
   GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
-  (VRight lInstalled) <- runE $ listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
-  let latestInstalled tool = (fmap (\lr -> TargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
+  (VRight lInstalled') <- runE $ listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
+  let latestInstalled tool = do
+        (_, xs) <- M.lookup tool lInstalled'
+        ListResult{..} <- lastMay xs
+        pure $ TargetVersion lCross lVer
 
   ghcup' <- forMM (getLatest dls ghcup) $ \(TargetVersion _ l, _) -> do
     (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer

lib-opt/GHCup/OptParse/Install.hs

@@ -391,6 +391,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            liftE $ runBothE' (installBindist
                        instTool
+                       Nothing
                        (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) regexDir "" Nothing Nothing Nothing (toInstallationInputSpec <$> defaultToolInstallSpec instTool pfreq v))
                        v
                        (maybe GHCupInternal IsolateDir isolateDir)

lib-opt/GHCup/OptParse/List.hs

@@ -45,6 +45,7 @@ import qualified Data.Text.IO                  as T
 import qualified System.Console.Pretty         as Pretty
 import Control.Exception.Safe (MonadMask)
 import GHCup.Types.Optics
+import qualified Data.Map.Strict as M
 
 
 
@@ -147,7 +148,7 @@ Examples:
 
 
 printListResult :: (HasLog env , MonadReader env m, MonadIO m)
-                => Bool -> PagerConfig -> Bool -> [ListResult] -> m ()
+                => Bool -> PagerConfig -> Bool -> ToolListResult -> m ()
 printListResult no_color (PagerConfig pList pCmd) raw lr = do
 
   let
@@ -172,12 +173,12 @@ printListResult no_color (PagerConfig pList pCmd) raw lr = do
           then x
           else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
         )
-        . fmap
-            (\ListResult {..} ->
+        . mconcat . fmap
+            (\(lTool, (_, ls)) -> ls <&> \ListResult{..} ->
               let marks = if
-                    | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))
-                    | lInstalled -> (color Green (if isWindows then "I " else "✓ "))
-                    | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))
+                   | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))
+                   | lInstalled -> (color Green (if isWindows then "I " else "✓ "))
+                   | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))
               in
                 (if raw then [] else [marks])
                   ++ [ fmap toLower . prettyShow $ lTool
@@ -200,7 +201,7 @@ printListResult no_color (PagerConfig pList pCmd) raw lr = do
                         )
                      ]
             )
-        $ lr
+        $ M.toList lr
   let cols =
         foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
       lengths = fmap (maximum . fmap strWidth) cols

lib-opt/GHCup/OptParse/Nuke.hs

@@ -24,6 +24,7 @@ import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad (forM_, void)
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
+import           Data.Foldable.WithIndex
 import           Data.Maybe
 import           Data.Variant.Excepts
 import           Options.Applicative     hiding ( style, ParseError )
@@ -82,7 +83,7 @@ nuke appState runLogger = do
 
        lInstalled' <- liftE $ listVersions Nothing [ListInstalled True] False True (Nothing, Nothing)
 
-       forM_ lInstalled' (\ListResult{..} -> liftE $ rmToolVersion lTool (TargetVersion lCross lVer))
+       iforM_ lInstalled' $ \tool (_, ls) -> forM_ ls $ \ListResult{..} -> liftE $ rmToolVersion tool (TargetVersion lCross lVer)
 
        lift rmGhcupDirs
 

lib-opt/GHCup/OptParse/Run.hs

@@ -306,7 +306,6 @@ run RunOptions{..} settings runAppState leanAppstate runLogger = do
 
    guessMode = if guessVersion settings then GLaxWithInstalled else GStrict
 
-   -- TODO: doesn't work for cross
    resolveToolchainFull :: ( MonadIOish m )
                         => Excepts
                              '[ TagNotFound