{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Glean.Shell.Terminal
  ( withPager
  ) where

import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import System.IO
#if __GLASGOW_HASKELL__ >= 810
import System.IO.Error
#endif
import System.Process

-- | Spawn a pager (currently hard-coded as `less` with some flags) and pass its
-- stdin handle to the action. The pager is spawned in parallel to the action
-- so the handle is wrapped in an 'MVar' which can be waited on. If the pager
-- fails for any reason, the 'MVar' will be set to the current stdout. The
-- action will be aborted if the pager exits before it is finished (allowing the
-- user to stop the action by quitting the pager).
withPager :: (MVar Handle -> IO a) -> IO (Maybe a)
withPager action = mask $ \restore -> do
  handle_var <- newEmptyMVar
  withAsyncWithUnmask (act handle_var) $ \async_action ->
    withAsyncWithUnmask (pager handle_var) $ \async_pager ->
      restore $ do
        r <- waitEitherCatch async_action async_pager
        case r of
          Left (Left exc)
#if __GLASGOW_HASKELL__ >= 810
            | Just e <- fromException exc, isResourceVanishedError e ->
              -- action got a "Broken pipe" error because the user
              -- quit the pager; ignore it
              return Nothing
#endif
            | otherwise -> throwIO exc
          Left (Right x) -> do
            void $ wait async_pager
            return $ Just x
          Right (Left _) -> Just <$> wait async_action
          Right (Right _) -> return Nothing
  where
    act handle_var restore =
      restore (action handle_var)
      `finally` do
        h <- readMVar handle_var
        when (h /= stdout) $ hClose h

    pager handle_var restore =
      restore (withCreateProcess
        (proc "less" ["-eFRX"]){ std_in = CreatePipe, std_err = CreatePipe }
        (\(Just inh) _ (Just errh) ph ->
          do
            putMVar handle_var inh
            withAsync (consume errh) $ const $ void $ waitForProcess ph
          `finally` hClose errh))
      `onException` tryPutMVar handle_var stdout

    consume h = do
      s <- hGetContents h
      void $ evaluate s