From 9c4e64baf1f83dc11f51454e7fc27f731f931681 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 13 Mar 2024 16:38:05 +0100 Subject: [PATCH] untested compileGHC IOAction --- lib-tui/GHCup/Brick/Actions.hs | 90 +++++++++++++++++++ lib-tui/GHCup/Brick/App.hs | 3 + .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 59 +++++++----- 3 files changed, 132 insertions(+), 20 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index f1db3c0..2728d05 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/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' #-} diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 5dcc904..1fed39e 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 6712687..8b24383 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/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 @@ -62,8 +81,8 @@ type CompileGHCMenu = Menu CompileGHCOptions Name create :: KeyCombination -> CompileGHCMenu create k = Menu.createMenu CompileGHCBox initialState k buttons fields where - initialState = - CompileGHCOptions + initialState = + CompileGHCOptions (Right "") Nothing Nothing @@ -83,39 +102,39 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath) bootstrapV i = case not $ emptyEditor i of - True -> + True -> let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init - readPath = do + readPath = do mfilepath <- filepathV i case mfilepath of Nothing -> Left "Invalid Empty value" Just f -> Right (Right f) - in if T.any isPathSeparator i + in if T.any isPathSeparator i then readPath else readVersion False -> Left "Invalid Empty value" - versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version) - versionV = bimap (const "Not a valid version") Just . version . T.init -- Brick adds \n at the end, hence T.init + versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) + 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 = + jobsV = let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack - in whenEmpty Nothing parseInt + in whenEmpty Nothing parseInt patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) patchesV = whenEmpty Nothing readPatches - where + where readUri :: T.Text -> Either String URI - readUri = first show . parseURI . UTF8.fromString . T.unpack - readPatches j = - let + readUri = first show . parseURI . UTF8.fromString . T.unpack + readPatches j = + let x = (bimap T.unpack (fmap Left) $ filepathV j) y = second (Just . Right) $ traverse readUri (T.split isSpace j) in first T.pack $ x <|> y filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathV i = + filepathV i = case not $ emptyEditor i of True -> absolutePathParser (T.unpack i) False -> Right Nothing @@ -130,13 +149,13 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem) systemV = whenEmpty Nothing readSys - where + where readSys i | T.toLower i == "hadrian" = Right $ Just Hadrian | T.toLower i == "make" = Right $ Just Hadrian | otherwise = Left "Not a valid Build System" - fields = + fields = [ Menu.createEditableField (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapV bootstrapGhc & Menu.fieldLabelL .~ "bootstrap-ghc" & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)" @@ -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