diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 2728d05..57a13d0 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -78,6 +78,8 @@ import Optics ((^.), to) import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS import Control.Concurrent (threadDelay) import qualified GHCup.GHC as GHC +import qualified GHCup.OptParse.Common as OptParse +import qualified GHCup.HLS as HLS @@ -535,7 +537,7 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = 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)) + <> "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." @@ -548,6 +550,87 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do compileGHC _ (_, ListResult{lTool = _}) = pure (Right ()) +compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => CompileHLS.CompileHLSOptions -> (Int, ListResult) -> m (Either String ()) +compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do + appstate <- ask + let run = + runResourceT + . runE @'[ AlreadyInstalled + , BuildFailed + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + , NotInstalled + , DirNotEmpty + , ArchiveResult + , 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 + + ghcs <- + liftE $ forM (compopts ^. CompileHLS.targetGHCs) + (\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC) + targetVer <- liftE $ GHCup.compileHLS + (HLS.SourceDist lVer) + ghcs + (compopts ^. CompileHLS.jobs) + (compopts ^. CompileHLS.overwriteVer) + (maybe GHCupInternal IsolateDir $ compopts ^. CompileHLS.isolateDir) + (compopts ^. CompileHLS.cabalProject) + (compopts ^. CompileHLS.cabalProjectLocal) + (compopts ^. CompileHLS.updateCabal) + (compopts ^. CompileHLS.patches) + (compopts ^. CompileHLS.cabalArgs) + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask + let vi2 = getVersionInfo (mkTVer targetVer) GHC dls2 + when + (compopts ^. CompileHLS.setCompile) + (liftE . void $ GHCup.setHLS targetVer SetHLSOnly Nothing) + pure (vi2, targetVer) + ) + case compileResult of + VRight (vi, tv) -> do + logInfo "HLS successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + liftIO $ putStr (T.unpack $ prettyVer tv) + 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 HLS... which should be impossible but, +-- it exhaustes pattern matches +compileHLS _ (_, ListResult{lTool = _}) = pure (Right ()) + + settings' :: IORef AppState {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 1fed39e..35309a8 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -191,6 +191,9 @@ compileHLSHandler 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.compileHLS iopts _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev eventHandler :: BrickEvent Name e -> EventM Name BrickState () diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index e7085fc..1bcd2fd 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -14,7 +14,24 @@ {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -module GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSOptions, CompileHLSMenu, create, handler, draw) where +module GHCup.Brick.Widgets.Menus.CompileHLS ( + CompileHLSOptions, + CompileHLSMenu, + create, + handler, + draw, + jobs, + setCompile, + updateCabal, + overwriteVer, + isolateDir, + cabalProject, + cabalProjectLocal, + patches, + targetGHCs, + cabalArgs, +) +where import GHCup.Brick.Widgets.Menu (Menu) import qualified GHCup.Brick.Widgets.Menu as Menu