Use pager for --help output

haskell · Aug 14, 2024 · bc00739 · bc00739
1 parent 026acab
commit bc00739
Show file tree

Hide file tree

Showing 3 changed files with 65 additions and 12 deletions.
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
@@ -20,14 +20,14 @@ 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
 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,21 +67,20 @@ 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
       B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
       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 <https://github.com/haskell/ghcup-hs/issues>|]
 
-  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
@@ -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
@@ -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
+
+