{-# 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
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)
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 }
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
withVty :: (Vty -> IO a) -> IO a
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)
withTty :: (Fd -> IO a) -> IO a
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 ()
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