diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 98c21285..c598f276 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -20,6 +20,7 @@ import qualified GHCup.GHC as GHC import qualified GHCup.HLS as HLS import GHCup.OptParse +import GHCup.Utils.Pager import GHCup.Download import GHCup.Errors import GHCup.Platform @@ -27,7 +28,6 @@ import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils import GHCup.Utils.Parsers (fromVersion) -import GHCup.Utils.Pager import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ @@ -67,10 +67,9 @@ import qualified GHCup.Types as Types -toSettings :: Options -> IO (Settings, KeyBindings, UserSettings) -toSettings options = do +toSettings :: Maybe FilePath -> Options -> IO (Settings, KeyBindings, UserSettings) +toSettings pagerCmd options = do noColor <- isJust <$> lookupEnv "NO_COLOR" - pagerCmd <- unsafeInterleaveIO getPager userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case VRight r -> pure r VLeft (V (JSONDecodeError e)) -> do @@ -78,10 +77,10 @@ toSettings options = do pure defaultUserSettings _ -> do die "Unexpected error!" - pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor pagerCmd + pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor where - mergeConf :: Options -> UserSettings -> Bool -> Maybe FilePath -> (Settings, KeyBindings) - mergeConf Options{..} UserSettings{..} noColor pagerCmd = + mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) + mergeConf Options{..} UserSettings{..} noColor = let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode @@ -172,18 +171,26 @@ ENV variables: Report bugs at |] - customExecParser + args <- getArgs + pagerCmd <- unsafeInterleaveIO getPager + + let + parseArgsWith opts' = execParserPure (prefs showHelpOnError) - (info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands) + (info (opts' <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands) (footerDoc (Just $ text main_footer)) - ) - >>= \opt@Options {..} -> do + ) args + + + handleParseResult' pagerCmd (argsHasHelp args) (parseArgsWith opts) >>= \case + opt@Options {..} -> do + dirs@Dirs{..} <- getAllDirs -- create ~/.ghcup dir ensureDirectories dirs - (settings, keybindings, userConf) <- toSettings opt + (settings, keybindings, userConf) <- toSettings pagerCmd opt -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index e0907f83..039cda67 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -63,6 +63,12 @@ import Data.Maybe import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text ) import Prelude hiding ( appendFile ) +import System.Exit +import System.Environment (getProgName) +import System.IO +import GHCup.Utils.Pager +import qualified Data.Text as T +import Data.Function ((&)) @@ -360,3 +366,27 @@ com = (progDesc "")) <> internal ) + +-- | Handle `ParserResult`. +handleParseResult' :: Maybe FilePath -> Bool -> ParserResult a -> IO a +handleParseResult' _ _ (Success a) = return a +handleParseResult' pagerCmd hasHelp (Failure failure) = do + progn <- getProgName + let (msg, exit) = renderFailure failure progn + case exit of + ExitSuccess + | hasHelp -> + void $ sendToPager' pagerCmd (T.lines $ T.pack msg) + | otherwise -> putStrLn msg + _ -> hPutStrLn stderr msg + exitWith exit +handleParseResult' _ _ (CompletionInvoked compl) = do + progn <- getProgName + msg <- execCompletion compl progn + putStr msg + exitSuccess + +-- | Checks whether any non-longopts args are '--help'. +argsHasHelp :: [String] -> Bool +argsHasHelp args = takeWhile (/= "--") args & elem "--help" + diff --git a/lib/GHCup/Utils/Pager.hs b/lib/GHCup/Utils/Pager.hs index f2318ab0..49121d70 100644 --- a/lib/GHCup/Utils/Pager.hs +++ b/lib/GHCup/Utils/Pager.hs @@ -16,6 +16,8 @@ import Data.Text (Text) import qualified Data.Text.IO as T import Control.Monad (forM_) import Control.Exception (IOException, try) +import GHCup.Utils.Output +import qualified Data.Text as T getPager :: IO (Maybe FilePath) @@ -48,3 +50,17 @@ sendToPager pager text = try @IOException ,errContents]) _ -> pure () + +sendToPager' :: Maybe FilePath -> [Text] -> IO (Either IOException ()) +sendToPager' Nothing text = do + forM_ text T.putStrLn + pure $ Right () +sendToPager' (Just pager) text = do + fits <- fitsInTerminal text + case fits of + Just True -> do + T.putStr $ T.unlines text + pure $ Right () + _ -> sendToPager pager text + +