{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Vgrep.App.Internal where

import           Control.Concurrent.Async
import           Control.Exception
import           Graphics.Vty             (Vty)
import qualified Graphics.Vty             as Vty
import           Pipes
import           System.Posix.IO
import           System.Posix.Types       (Fd)

import Vgrep.Type


-- | 'User' events do have higher priority than 'System' events, so that
-- the application stays responsive even in case of event queue congestion.
data EventPriority = User | System deriving (EventPriority -> EventPriority -> Bool
(EventPriority -> EventPriority -> Bool)
-> (EventPriority -> EventPriority -> Bool) -> Eq EventPriority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventPriority -> EventPriority -> Bool
$c/= :: EventPriority -> EventPriority -> Bool
== :: EventPriority -> EventPriority -> Bool
$c== :: EventPriority -> EventPriority -> Bool
Eq, Eq EventPriority
Eq EventPriority
-> (EventPriority -> EventPriority -> Ordering)
-> (EventPriority -> EventPriority -> Bool)
-> (EventPriority -> EventPriority -> Bool)
-> (EventPriority -> EventPriority -> Bool)
-> (EventPriority -> EventPriority -> Bool)
-> (EventPriority -> EventPriority -> EventPriority)
-> (EventPriority -> EventPriority -> EventPriority)
-> Ord EventPriority
EventPriority -> EventPriority -> Bool
EventPriority -> EventPriority -> Ordering
EventPriority -> EventPriority -> EventPriority
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventPriority -> EventPriority -> EventPriority
$cmin :: EventPriority -> EventPriority -> EventPriority
max :: EventPriority -> EventPriority -> EventPriority
$cmax :: EventPriority -> EventPriority -> EventPriority
>= :: EventPriority -> EventPriority -> Bool
$c>= :: EventPriority -> EventPriority -> Bool
> :: EventPriority -> EventPriority -> Bool
$c> :: EventPriority -> EventPriority -> Bool
<= :: EventPriority -> EventPriority -> Bool
$c<= :: EventPriority -> EventPriority -> Bool
< :: EventPriority -> EventPriority -> Bool
$c< :: EventPriority -> EventPriority -> Bool
compare :: EventPriority -> EventPriority -> Ordering
$ccompare :: EventPriority -> EventPriority -> Ordering
$cp1Ord :: Eq EventPriority
Ord, Int -> EventPriority
EventPriority -> Int
EventPriority -> [EventPriority]
EventPriority -> EventPriority
EventPriority -> EventPriority -> [EventPriority]
EventPriority -> EventPriority -> EventPriority -> [EventPriority]
(EventPriority -> EventPriority)
-> (EventPriority -> EventPriority)
-> (Int -> EventPriority)
-> (EventPriority -> Int)
-> (EventPriority -> [EventPriority])
-> (EventPriority -> EventPriority -> [EventPriority])
-> (EventPriority -> EventPriority -> [EventPriority])
-> (EventPriority
    -> EventPriority -> EventPriority -> [EventPriority])
-> Enum EventPriority
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EventPriority -> EventPriority -> EventPriority -> [EventPriority]
$cenumFromThenTo :: EventPriority -> EventPriority -> EventPriority -> [EventPriority]
enumFromTo :: EventPriority -> EventPriority -> [EventPriority]
$cenumFromTo :: EventPriority -> EventPriority -> [EventPriority]
enumFromThen :: EventPriority -> EventPriority -> [EventPriority]
$cenumFromThen :: EventPriority -> EventPriority -> [EventPriority]
enumFrom :: EventPriority -> [EventPriority]
$cenumFrom :: EventPriority -> [EventPriority]
fromEnum :: EventPriority -> Int
$cfromEnum :: EventPriority -> Int
toEnum :: Int -> EventPriority
$ctoEnum :: Int -> EventPriority
pred :: EventPriority -> EventPriority
$cpred :: EventPriority -> EventPriority
succ :: EventPriority -> EventPriority
$csucc :: EventPriority -> EventPriority
Enum)


-- | We need the viewport in order to initialize the app, which in turn will
-- start 'Vty.Vty'. To resolve this circular dependency, we start once 'Vty.Vty'
-- in order to determine the display viewport, and shut it down again
-- immediately.
viewportHack :: IO Viewport
viewportHack :: IO Viewport
viewportHack = (Vty -> IO Viewport) -> IO Viewport
forall a. (Vty -> IO a) -> IO a
withVty ((Vty -> IO Viewport) -> IO Viewport)
-> (Vty -> IO Viewport) -> IO Viewport
forall a b. (a -> b) -> a -> b
$ \Vty
vty -> do
    (Int
width, Int
height) <- Output -> IO (Int, Int)
Vty.displayBounds (Vty -> Output
Vty.outputIface Vty
vty)
    Viewport -> IO Viewport
forall (f :: * -> *) a. Applicative f => a -> f a
pure Viewport :: Int -> Int -> Viewport
Viewport { _vpWidth :: Int
_vpWidth = Int
width , _vpHeight :: Int
_vpHeight = Int
height }

-- | Spawns a thread parallel to the action that listens to 'Vty' events and
-- redirects them to the 'Consumer'.
withEvThread :: Consumer Vty.Event IO () -> Vty -> VgrepT s IO a -> VgrepT s IO a
withEvThread :: Consumer Event IO () -> Vty -> VgrepT s IO a -> VgrepT s IO a
withEvThread Consumer Event IO ()
sink Vty
vty =
    IO (Async ())
-> (Async () -> IO ())
-> (Async () -> VgrepT s IO a)
-> VgrepT s IO a
forall a c s b.
IO a -> (a -> IO c) -> (a -> VgrepT s IO b) -> VgrepT s IO b
vgrepBracket IO (Async ())
createEvThread Async () -> IO ()
forall a. Async a -> IO ()
cancel ((Async () -> VgrepT s IO a) -> VgrepT s IO a)
-> (VgrepT s IO a -> Async () -> VgrepT s IO a)
-> VgrepT s IO a
-> VgrepT s IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VgrepT s IO a -> Async () -> VgrepT s IO a
forall a b. a -> b -> a
const
  where
    createEvThread :: IO (Async ())
createEvThread = (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ()))
-> (Effect IO () -> IO ()) -> Effect IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect IO () -> IO ()
forall (m :: * -> *) r. Monad m => Effect m r -> m r
runEffect) (Effect IO () -> IO (Async ())) -> Effect IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO Event -> Proxy X () () X IO Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Vty -> IO Event
Vty.nextEvent Vty
vty) Proxy X () () X IO Event -> Consumer Event IO () -> Effect IO ()
forall (m :: * -> *) a' a y' y b c.
Functor m =>
Proxy a' a y' y m b -> Proxy () b y' y m c -> Proxy a' a y' y m c
>~ Consumer Event IO ()
sink


-- | Passes a 'Vty' instance to the action and shuts it down properly after the
-- action finishes. The 'Vty.inputFd' and 'Vty.outputFd' handles are connected
-- to @\/dev\/tty@ (see 'tty').
withVty :: (Vty -> IO a) -> IO a
-- | Like 'withVty', but lifted to @'VgrepT' s 'IO'@.
withVgrepVty :: (Vty -> VgrepT s IO a) -> VgrepT s IO a
((Vty -> IO a) -> IO a
withVty, (Vty -> VgrepT s IO a) -> VgrepT s IO a
withVgrepVty) =
    let initVty :: Fd -> IO Vty
initVty Fd
fd = do
            Config
cfg <- IO Config
Vty.standardIOConfig
            Config -> IO Vty
Vty.mkVty Config
cfg { inputFd :: Maybe Fd
Vty.inputFd  = Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
fd
                          , outputFd :: Maybe Fd
Vty.outputFd = Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
fd }
    in  ( \Vty -> IO a
action -> (Fd -> IO a) -> IO a
forall a. (Fd -> IO a) -> IO a
withTty      ((Fd -> IO a) -> IO a) -> (Fd -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> IO Vty -> (Vty -> IO ()) -> (Vty -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket      (Fd -> IO Vty
initVty Fd
fd) Vty -> IO ()
Vty.shutdown Vty -> IO a
action
        , \Vty -> VgrepT s IO a
action -> (Fd -> VgrepT s IO a) -> VgrepT s IO a
forall s a. (Fd -> VgrepT s IO a) -> VgrepT s IO a
withVgrepTty ((Fd -> VgrepT s IO a) -> VgrepT s IO a)
-> (Fd -> VgrepT s IO a) -> VgrepT s IO a
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> IO Vty -> (Vty -> IO ()) -> (Vty -> VgrepT s IO a) -> VgrepT s IO a
forall a c s b.
IO a -> (a -> IO c) -> (a -> VgrepT s IO b) -> VgrepT s IO b
vgrepBracket (Fd -> IO Vty
initVty Fd
fd) Vty -> IO ()
Vty.shutdown Vty -> VgrepT s IO a
action)


-- | Passes two file descriptors for read and write access to @\/dev\/tty@ to
-- the action, and closes them after the action has finished.
withTty :: (Fd -> IO a) -> IO a
-- | Like 'withTty', but lifted to @'VgrepT' s 'IO'@.
withVgrepTty :: (Fd -> VgrepT s IO a) -> VgrepT s IO a
((Fd -> IO a) -> IO a
withTty, (Fd -> VgrepT s IO a) -> VgrepT s IO a
withVgrepTty) = (IO Fd -> (Fd -> IO ()) -> (Fd -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Fd
before Fd -> IO ()
after, IO Fd -> (Fd -> IO ()) -> (Fd -> VgrepT s IO a) -> VgrepT s IO a
forall a c s b.
IO a -> (a -> IO c) -> (a -> VgrepT s IO b) -> VgrepT s IO b
vgrepBracket IO Fd
before Fd -> IO ()
after)
  where
    before :: IO Fd
before = IO Fd
tty
    after :: Fd -> IO ()
after Fd
fd = Fd -> IO ()
closeFd Fd
fd IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO ()
ignoreIOException
    ignoreIOException :: IOException -> IO ()
    ignoreIOException :: IOException -> IO ()
ignoreIOException IOException
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Opens @\/dev\/tty@ in Read/Write mode. Should be connected to the @stdin@ and
-- @stdout@ of a GUI process (e. g. 'Vty.Vty').
tty :: IO Fd
tty :: IO Fd
tty = FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
"/dev/tty" OpenMode
ReadWrite Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags