Implement pager support wrt #1118

haskell · Sep 24, 2024 · 8f10cba · 8f10cba
1 parent 2dec416
commit 8f10cba
Show file tree

Hide file tree

Showing 8 changed files with 118 additions and 12 deletions.
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
@@ -27,6 +27,7 @@ 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
@@ -55,6 +56,7 @@ import           Prelude                 hiding ( appendFile )
 import           System.Environment
 import           System.Exit
 import           System.IO               hiding ( appendFile )
+import           System.IO.Unsafe               ( unsafeInterleaveIO )
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.ByteString               as B
@@ -68,17 +70,18 @@ import qualified GHCup.Types                   as Types
 toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
 toSettings 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
+  pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor pagerCmd
  where
-   mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
-   mergeConf Options{..} UserSettings{..} noColor =
+   mergeConf :: Options -> UserSettings -> Bool -> Maybe FilePath -> (Settings, KeyBindings)
+   mergeConf Options{..} UserSettings{..} noColor pagerCmd =
      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
@@ -93,6 +96,9 @@ toSettings options = do
          platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
          mirrors  = fromMaybe (Types.mirrors defaultSettings) uMirrors
          defGHCConfOptions  = fromMaybe (Types.defGHCConfOptions defaultSettings) uDefGHCConfOptions
+         pager = case fromMaybe (fromMaybe (Types.pager defaultSettings) uPager) (flip PagerConfig Nothing <$> optPager) of
+                   PagerConfig b Nothing -> PagerConfig b pagerCmd
+                   x -> x
      in (Settings {..}, keyBindings)
 #if defined(INTERNAL_DOWNLOADER)
    defaultDownloader = Internal
@@ -299,7 +305,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             Test testCommand           -> test testCommand settings appState runLogger
             Set setCommand             -> set setCommand runAppState runLeanAppState runLogger
             UnSet unsetCommand         -> unset unsetCommand runLeanAppState runLogger
-            List lo                    -> list lo no_color runAppState
+            List lo                    -> list lo no_color (pager settings) runAppState
             Rm rmCommand               -> rm rmCommand runAppState runLogger
             DInfo                      -> dinfo runAppState runLogger
             Compile compileCommand     -> compile compileCommand settings dirs runAppState runLogger

diff --git a/ghcup.cabal b/ghcup.cabal
@@ -145,6 +145,7 @@ library
     GHCup.Utils.Tar
     GHCup.Utils.Tar.Types
     GHCup.Utils.URI
+    GHCup.Utils.Pager
     GHCup.Utils.Parsers
     GHCup.Version
 
@@ -185,6 +186,7 @@ library
     , casing                ^>=0.1.4.1
     , containers            ^>=0.6
     , conduit               ^>=1.3
+    , conduit-extra         ^>=1.3
     , cryptohash-sha256     ^>=0.11.101.0
     , deepseq               ^>=1.4.4.0
     , directory             ^>=1.3.6.0

diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs
@@ -81,6 +81,7 @@ data Options = Options
   , optNoNetwork   :: Maybe Bool
   , optGpg         :: Maybe GPGSetting
   , optStackSetup  :: Maybe Bool
+  , optPager       :: Maybe Bool
   -- commands
   , optCommand     :: Command
   }
@@ -177,6 +178,7 @@ opts =
           <> completer (listCompleter ["strict", "lax", "none"])
           ))
     <*> invertableSwitch "stack-setup" Nothing False (help "Use stack's setup info for discovering and installing GHC versions")
+    <*> (invertableSwitch "paginate" Nothing False (help "Send output (e.g. from 'ghcup list') through pager (default: disabled)"))
     <*> com
 
 

diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs
@@ -135,7 +135,8 @@ updateSettings usl usr =
        platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
        mirrors' = uMirrors usl <|> uMirrors usr
        defGHCconfOptions' = uDefGHCConfOptions usl <|> uDefGHCConfOptions usr
-   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions'
+       pagerConfig' = uPager usl <|> uPager usr
+   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' pagerConfig'
  where
   updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
   updateKeyBindings Nothing Nothing = Nothing

diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs
@@ -17,6 +17,7 @@ import           GHCup.Types
 import           GHCup.Utils.Parsers (dayParser, toolParser, criteriaParser)
 import           GHCup.OptParse.Common
 import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Pager
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -139,8 +140,9 @@ Examples:
     -----------------
 
 
-printListResult :: Bool -> Bool -> [ListResult] -> IO ()
-printListResult no_color raw lr = do
+printListResult :: (HasLog env , MonadReader env m, MonadIO m)
+                => Bool -> PagerConfig -> Bool -> [ListResult] -> m ()
+printListResult no_color (PagerConfig pList pCmd) raw lr = do
 
   let
     color | raw || no_color = (\_ x -> x)
@@ -197,9 +199,13 @@ printListResult no_color raw lr = do
       lengths = fmap (maximum . fmap strWidth) cols
       padded  = fmap (\xs -> zipWith padTo xs lengths) rows
 
-  forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
+  let text = fmap unwords (if raw then rows else padded)
+  if | pList
+     , not raw
+     , Just cmd <- pCmd -> do
  where
 
+  padTo :: String -> Int -> String
   padTo str' x =
     let lstr = strWidth str'
         add' = x - lstr
@@ -287,6 +293,13 @@ printListResult no_color raw lr = do
       | c >= '\x1F300' && c <= '\x1F773' -> 1
       | c >= '\x20000' && c <= '\x3FFFD' -> 2
       | otherwise                        -> 1
+         r <- liftIO $ sendToPager cmd (T.pack <$> text)
+         case r of
+           Left e -> do
+             logDebug $ "Failed to send to pager '" <> T.pack cmd <> "': " <> T.pack (show e)
+             liftIO $ forM_ text putStrLn
+           Right _ -> pure ()
+     | otherwise -> liftIO $ forM_ text putStrLn
 
 
 
@@ -305,11 +318,12 @@ list :: ( Monad m
          )
       => ListOptions
       -> Bool
+      -> PagerConfig
       -> (ReaderT AppState m ExitCode -> m ExitCode)
       -> m ExitCode
-list ListOptions{..} no_color runAppState =
+list ListOptions{..} no_color pgc runAppState =
   runAppState (do
       l <- listVersions loTool (maybeToList lCriteria) lHideOld lShowNightly (lFrom, lTo)
-      liftIO $ printListResult no_color lRawFormat l
+      printListResult no_color pgc lRawFormat l
       pure ExitSuccess
     )
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
@@ -393,11 +393,12 @@ data UserSettings = UserSettings
   , uPlatformOverride  :: Maybe PlatformRequest
   , uMirrors           :: Maybe DownloadMirrors
   , uDefGHCConfOptions :: Maybe [String]
+  , uPager             :: Maybe PagerConfig
   }
   deriving (Show, GHC.Generic, Eq)
 
 defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
 fromSettings Settings{..} Nothing =
@@ -416,6 +417,7 @@ fromSettings Settings{..} Nothing =
     , uPlatformOverride = platformOverride
     , uMirrors = Just mirrors
     , uDefGHCConfOptions = Just defGHCConfOptions
+    , uPager = Just pager
   }
 fromSettings Settings{..} (Just KeyBindings{..}) =
   let ukb = UserKeyBindings
@@ -443,6 +445,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
     , uPlatformOverride = platformOverride
     , uMirrors = Just mirrors
     , uDefGHCConfOptions = Just defGHCConfOptions
+    , uPager = Just pager
   }
 
 data UserKeyBindings = UserKeyBindings
@@ -529,14 +532,29 @@ data Settings = Settings
   , platformOverride  :: Maybe PlatformRequest
   , mirrors           :: DownloadMirrors
   , defGHCConfOptions :: [String]
+  , pager             :: PagerConfig
   }
   deriving (Show, GHC.Generic)
 
+data PagerConfig = PagerConfig {
+    pagerList :: Bool
+  , pagerCmd  :: Maybe String
+  }
+  deriving (Show, GHC.Generic, Eq)
+
+instance NFData PagerConfig
+
+defaultPagerConfig :: PagerConfig
+defaultPagerConfig = PagerConfig False Nothing
+
+allPagerConfig :: String -> PagerConfig
+allPagerConfig cmd = PagerConfig True (Just cmd)
+
 defaultMetaCache :: Integer
 defaultMetaCache = 300 -- 5 minutes
 
 defaultSettings :: Settings
-defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) []
+defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) [] defaultPagerConfig
 
 instance NFData Settings
 

diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs
@@ -434,6 +434,18 @@ instance FromJSON KeyCombination where
 instance ToJSON KeyCombination where
   toJSON (KeyCombination k m) = object ["Key" .= k, "Mods" .= m]
 
+instance FromJSON PagerConfig where
+  parseJSON v = p1 v <|> p2 v <|> p3 v
+   where
+    p2 = withBool "PagerConfig" $ \b -> pure $ PagerConfig b Nothing
+    p3 = withText "PagerConfig" $ \t -> pure $ allPagerConfig (T.unpack t)
+    p1 = withObject "PagerConfig" $ \o -> do
+       list <- o .:  "list"
+       cmd  <- o .:? "cmd"
+       pure $ PagerConfig list cmd
+
+
+deriveToJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "pager-") . T.pack . kebab $ str' } ''PagerConfig
 deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings

diff --git a/lib/GHCup/Utils/Pager.hs b/lib/GHCup/Utils/Pager.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE RankNTypes  #-}
+
+module GHCup.Utils.Pager where
+
+import GHCup.Prelude
+import System.Environment
+import GHCup.Utils.Dirs (findExecutable)
+import Control.Applicative (asum)
+import System.Process
+import System.Exit
+import System.IO
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+import Control.Monad (forM_)
+import Control.Exception (IOException, try)
+
+
+getPager :: IO (Maybe FilePath)
+getPager = do
+  lookupEnv "GHCUP_PAGER" >>= \case
+    Just r  -> pure $ Just r
+    Nothing -> lookupEnv "PAGER" >>= \case
+      Just r' -> pure $ Just r'
+      Nothing -> do
+        let pagers
+              | isWindows = ["most.exe", "more.exe", "less.exe"]
+              | otherwise = ["most", "more", "less"]
+        asum $ fmap findExecutable pagers
+
+sendToPager :: FilePath -> [Text] -> IO (Either IOException ())
+sendToPager pager text = do
+  (Just stdinH, _, Just stderrH, ph) <-
+    createProcess
+      $ (shell pager) { std_in = CreatePipe
+                      , std_err = CreatePipe
+                      }
+  try @IOException (forM_ text $ T.hPutStrLn stdinH) >>= \case
+    Left e -> pure $ Left e
+    Right _ -> do
+      hClose stdinH
+      exitCode <- waitForProcess ph
+      case exitCode of
+        ExitFailure i ->
+          do errContents <- hGetContents stderrH
+             fail (unlines [mappend "Pager exited with exit code " (show i)
+                           ,errContents])
+        _ -> pure $ Right ()
+