untested compileGHC IOAction

lib-tui/GHCup/Brick/Actions.hs

@@ -76,6 +76,8 @@ import           Optics.Getter (view)
 import Optics.Optic ((%))
 import Optics ((^.), to)
 import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
+import Control.Concurrent (threadDelay)
+import qualified GHCup.GHC as GHC
 
 
 
@@ -457,6 +459,94 @@ changelog' (_, ListResult {..}) = do
         Right _ -> pure $ Right ()
         Left  e -> pure $ Left $ prettyHFError e
 
+compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) 
+           => CompileGHC.CompileGHCOptions -> (Int, ListResult) -> m (Either String ())
+compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do
+  appstate <- ask
+  let run = 
+        runResourceT
+         . runE @'[ AlreadyInstalled
+                  , BuildFailed
+                  , DigestError
+                  , ContentLengthError
+                  , GPGError
+                  , DownloadFailed
+                  , GHCupSetError
+                  , NoDownload
+                  , NotFoundInPATH
+                  , PatchFailed
+                  , UnknownArchive
+                  , TarDirDoesNotExist
+                  , NotInstalled
+                  , DirNotEmpty
+                  , ArchiveResult
+                  , FileDoesNotExistError
+                  , HadrianNotFound
+                  , InvalidBuildConfig
+                  , ProcessError
+                  , CopyError
+                  , BuildFailed
+                  , UninstallFailed
+                  , MergeFileTreeError
+                  ]
+  compileResult <- run (do
+      AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
+      let vi = getVersionInfo (mkTVer lVer) GHC dls
+      forM_ (_viPreCompile =<< vi) $ \msg -> do
+        logInfo msg
+        logInfo
+          "...waiting for 5 seconds, you can still abort..."
+        liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+
+      targetVer <- liftE $ GHCup.compileGHC 
+                    (GHC.SourceDist lVer)
+                    (compopts ^. CompileGHC.crossTarget)
+                    (compopts ^. CompileGHC.overwriteVer)
+                    (compopts ^. CompileGHC.bootstrapGhc)
+                    (compopts ^. CompileGHC.jobs)
+                    (compopts ^. CompileGHC.buildConfig)
+                    (compopts ^. CompileGHC.patches)
+                    (compopts ^. CompileGHC.addConfArgs)
+                    (compopts ^. CompileGHC.buildFlavour)
+                    (compopts ^. CompileGHC.buildSystem)
+                    (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir)
+      AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
+      let vi2 = getVersionInfo targetVer GHC dls2
+      when
+        (compopts ^. CompileGHC.setCompile)
+        (liftE . void $ GHCup.setGHC targetVer SetGHCOnly Nothing)
+      pure (vi2, targetVer)
+      )
+  case compileResult of
+      VRight (vi, tv) -> do
+        logInfo "GHC successfully compiled and installed"
+        forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+        liftIO $ putStr (T.unpack $ tVerToText tv)
+        pure $ Right ()
+      VLeft (V (AlreadyInstalled _ v)) -> do
+        logWarn $
+          "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
+        pure $ Right ()
+      VLeft (V (DirNotEmpty fp)) -> do
+        logError $
+          "Install directory " <> T.pack fp <> " is not empty."
+        pure $ Right ()
+      VLeft err@(V (BuildFailed tmpdir _)) -> do
+        case keepDirs (appstate & settings) of
+          Never -> logError $ T.pack $ prettyHFError err
+          _ -> logError $ T.pack (prettyHFError err) <> "\n" 
+            <> "Check the logs at " <> T.pack (fromGHCupPath (appstate & dirs & logsDir)) 
+            <> " and the build directory "
+            <> T.pack tmpdir <> " for more clues." <> "\n" 
+            <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards."
+        pure $ Right ()
+      VLeft e -> do
+        logError $ T.pack $ prettyHFError e
+        pure $ Right ()
+-- This is the case when the tool is not GHC... which should be impossible but,
+-- it exhaustes pattern matches
+compileGHC _ (_, ListResult{lTool = _}) = pure (Right ())
+
 
 settings' :: IORef AppState
 {-# NOINLINE settings' #-}

lib-tui/GHCup/Brick/App.hs

@@ -172,6 +172,9 @@ compileGHCHandler ev = do
           && m == mods
           && n `elem` [Menu.fieldName button | button <- buttons]
       -> mode .= ContextPanel
+    (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
+        let iopts = ctx ^. Menu.menuStateL
+        Actions.withIOAction $ Actions.compileGHC iopts
     _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev
 
 

lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs

@@ -14,7 +14,24 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
-module GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCOptions, CompileGHCMenu, create, handler, draw) where
+module GHCup.Brick.Widgets.Menus.CompileGHC (
+  CompileGHCOptions,
+  CompileGHCMenu,
+  create,
+  handler,
+  draw,
+  bootstrapGhc,
+  jobs,
+  buildConfig,
+  patches,
+  crossTarget,
+  addConfArgs,
+  setCompile,
+  overwriteVer,
+  buildFlavour,
+  buildSystem,
+  isolateDir,
+) where
 
 import GHCup.Brick.Widgets.Menu (Menu)
 import qualified GHCup.Brick.Widgets.Menu as Menu
@@ -26,7 +43,8 @@ import Brick
 import           Prelude                 hiding ( appendFile )
 import           Optics.TH (makeLenses)
 import qualified GHCup.Brick.Common as Common
-import GHCup.Types (KeyCombination, BuildSystem (Hadrian))
+import GHCup.Types
+    ( KeyCombination, BuildSystem(Hadrian), VersionPattern )
 import URI.ByteString (URI)
 import qualified Data.Text as T
 import qualified Data.ByteString.UTF8 as UTF8
@@ -40,6 +58,7 @@ import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise)
 import Control.Applicative (Alternative((<|>)))
 import Text.Read (readEither)
 import GHCup.Prelude (stripNewlineEnd)
+import qualified GHCup.OptParse.Common as OptParse
 
 data CompileGHCOptions = CompileGHCOptions
   { _bootstrapGhc :: Either Version FilePath
@@ -49,7 +68,7 @@ data CompileGHCOptions = CompileGHCOptions
   , _crossTarget  :: Maybe T.Text
   , _addConfArgs  :: [T.Text]
   , _setCompile   :: Bool
-  , _ovewrwiteVer :: Maybe Version
+  , _overwriteVer :: Maybe [VersionPattern]
   , _buildFlavour :: Maybe String
   , _buildSystem  :: Maybe BuildSystem
   , _isolateDir   :: Maybe FilePath
@@ -95,8 +114,8 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
                 else readVersion
         False -> Left "Invalid Empty value"
 
-    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version)
+    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
-    versionV = bimap (const "Not a valid version") Just . version . T.init  -- Brick adds \n at the end, hence T.init
+    versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack . T.init)  -- Brick adds \n at the end, hence T.init
 
     jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
     jobsV =
@@ -159,7 +178,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
           & Menu.fieldLabelL .~ "set"
           & Menu.fieldHelpMsgL .~ "Set as active version after install"
-      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV ovewrwiteVer
+      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV overwriteVer
           & Menu.fieldLabelL .~ "overwrite-version"
           & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
       , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour