{-|
 - Module: Reflex.Vty.GHCi
 - Description: Vty widgets useful when building your own GHCi runner
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
module Reflex.Vty.GHCi where

import Control.Monad ((<=<), void)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Reflex.Network
import Reflex.Process
import Reflex.Process.GHCi
import Reflex.Vty
import qualified Graphics.Vty.Input as V
import qualified System.Process as P

-- | Display the overall status of the GHCi session, including exit information in case GHCi has quit
statusDisplay
  :: ( PostBuild t m
     , MonadHold t m
     )
  => Ghci t
  -> VtyWidget t m ()
statusDisplay :: Ghci t -> VtyWidget t m ()
statusDisplay g :: Ghci t
g = do
  Event t ()
pb <- VtyWidget t m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Behavior t Text -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Behavior t Text -> VtyWidget t m ()
text (Behavior t Text -> VtyWidget t m ())
-> (Event t Text -> VtyWidget t m (Behavior t Text))
-> Event t Text
-> VtyWidget t m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Event t Text -> VtyWidget t m (Behavior t Text)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold "" (Event t Text -> VtyWidget t m ())
-> Event t Text -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ [Event t Text] -> Event t Text
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ Status -> Text
forall a. IsString a => Status -> a
statusMessage (Status -> Text) -> Event t Status -> Event t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Status -> Event t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated (Ghci t -> Dynamic t Status
forall t. Ghci t -> Dynamic t Status
_ghci_status Ghci t
g)
    , Status -> Text
forall a. IsString a => Status -> a
statusMessage (Status -> Text) -> Event t Status -> Event t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Status -> Event t () -> Event t Status
forall k (t :: k) b a.
Reflex t =>
Behavior t b -> Event t a -> Event t b
tag (Dynamic t Status -> Behavior t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current (Dynamic t Status -> Behavior t Status)
-> Dynamic t Status -> Behavior t Status
forall a b. (a -> b) -> a -> b
$ Ghci t -> Dynamic t Status
forall t. Ghci t -> Dynamic t Status
_ghci_status Ghci t
g) Event t ()
pb
    , ("Command exited with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (ExitCode -> Text) -> ExitCode -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ExitCode -> String) -> ExitCode -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExitCode -> String
forall a. Show a => a -> String
show (ExitCode -> Text) -> Event t ExitCode -> Event t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process t ByteString ByteString -> Event t ExitCode
forall t o e. Process t o e -> Event t ExitCode
_process_exit (Ghci t -> Process t ByteString ByteString
forall t. Ghci t -> Process t ByteString ByteString
_ghci_process Ghci t
g)
    ]

-- | A scrollable widget that displays a message at the bottom of the widget
-- when there is additional content to view.
scrollableOutput
  :: ( Reflex t
     , MonadNodeId m
     , MonadHold t m
     , MonadFix m
     , PostBuild t m
     )
  => Behavior t ByteString
  -> VtyWidget t m ()
scrollableOutput :: Behavior t ByteString -> VtyWidget t m ()
scrollableOutput out :: Behavior t ByteString
out = Layout t m () -> VtyWidget t m ()
forall (m :: * -> *) t a.
(MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m) =>
Layout t m a -> VtyWidget t m a
col (Layout t m () -> VtyWidget t m ())
-> Layout t m () -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ do
  Dynamic t Int
dh <- Layout t m (Dynamic t Int)
forall t (m :: * -> *). HasDisplaySize t m => m (Dynamic t Int)
displayHeight
  Behavior t (Int, Int)
scroll <- VtyWidget t m (Behavior t (Int, Int))
-> Layout t m (Behavior t (Int, Int))
forall t (m :: * -> *) a.
(Reflex t, Monad m, MonadNodeId m) =>
VtyWidget t m a -> Layout t m a
stretch (VtyWidget t m (Behavior t (Int, Int))
 -> Layout t m (Behavior t (Int, Int)))
-> VtyWidget t m (Behavior t (Int, Int))
-> Layout t m (Behavior t (Int, Int))
forall a b. (a -> b) -> a -> b
$ Event t Int
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
forall t (m :: * -> *).
(Reflex t, MonadHold t m, MonadFix m) =>
Event t Int
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
scrollableText Event t Int
forall k (t :: k) a. Reflex t => Event t a
never (Behavior t Text -> VtyWidget t m (Behavior t (Int, Int)))
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Behavior t ByteString -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t ByteString
out
  Dynamic t Int -> VtyWidget t m () -> Layout t m ()
forall t (m :: * -> *) a.
(Reflex t, Monad m, MonadNodeId m) =>
Dynamic t Int -> VtyWidget t m a -> Layout t m a
fixed 1 (VtyWidget t m () -> Layout t m ())
-> VtyWidget t m () -> Layout t m ()
forall a b. (a -> b) -> a -> b
$ Behavior t Text -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Behavior t Text -> VtyWidget t m ()
text (Behavior t Text -> VtyWidget t m ())
-> Behavior t Text -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$
    let f :: a -> (a, a) -> p
f h :: a
h (ix :: a
ix, n :: a
n) = if a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
ix a -> a -> a
forall a. Num a => a -> a -> a
+ 1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
h
          then "↓ More ↓"
          else ""
    in Int -> (Int, Int) -> Text
forall a p. (Ord a, Num a, IsString p) => a -> (a, a) -> p
f (Int -> (Int, Int) -> Text)
-> Behavior t Int -> Behavior t ((Int, Int) -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh Behavior t ((Int, Int) -> Text)
-> Behavior t (Int, Int) -> Behavior t Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t (Int, Int)
scroll

-- | A scrollable widget that scrolls down as output goes past the end of the widget
scrollingOutput
  :: ( Reflex t
     , Monad m
     , MonadHold t m
     , MonadFix m
     )
  => Dynamic t ByteString
  -> VtyWidget t m ()
scrollingOutput :: Dynamic t ByteString -> VtyWidget t m ()
scrollingOutput out :: Dynamic t ByteString
out = do
  Dynamic t Int
dh <- VtyWidget t m (Dynamic t Int)
forall t (m :: * -> *). HasDisplaySize t m => m (Dynamic t Int)
displayHeight
  let scrollBy :: a -> (a, a) -> Maybe a
scrollBy h :: a
h (ix :: a
ix, n :: a
n) =
        if | a
ix a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
h -> Maybe a
forall a. Maybe a
Nothing -- Scrolled to the top and we don't have to scroll down
           | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
h Bool -> Bool -> Bool
&& a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
ix a -> a -> a
forall a. Num a => a -> a -> a
- a
h a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> a -> Maybe a
forall a. a -> Maybe a
Just 1
           | Bool
otherwise -> Maybe a
forall a. Maybe a
Nothing
  rec Behavior t (Int, Int)
scroll <- Event t Int
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
forall t (m :: * -> *).
(Reflex t, MonadHold t m, MonadFix m) =>
Event t Int
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
scrollableText (Behavior t (Maybe Int) -> Event t ByteString -> Event t Int
forall k (t :: k) b a.
Reflex t =>
Behavior t (Maybe b) -> Event t a -> Event t b
tagMaybe (Int -> (Int, Int) -> Maybe Int
forall a a. (Ord a, Num a, Num a) => a -> (a, a) -> Maybe a
scrollBy (Int -> (Int, Int) -> Maybe Int)
-> Behavior t Int -> Behavior t ((Int, Int) -> Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh Behavior t ((Int, Int) -> Maybe Int)
-> Behavior t (Int, Int) -> Behavior t (Maybe Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t (Int, Int)
scroll) (Event t ByteString -> Event t Int)
-> Event t ByteString -> Event t Int
forall a b. (a -> b) -> a -> b
$ Dynamic t ByteString -> Event t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t ByteString
out) (Behavior t Text -> VtyWidget t m (Behavior t (Int, Int)))
-> Behavior t Text -> VtyWidget t m (Behavior t (Int, Int))
forall a b. (a -> b) -> a -> b
$
        ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Behavior t ByteString -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t ByteString -> Behavior t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t ByteString
out
  () -> VtyWidget t m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Display the output GHCi produces when it's loading the requested modules (e.g., warnings)
ghciModuleStatus
  :: ( MonadNodeId m
     , PostBuild t m
     , MonadHold t m
     , MonadFix m
     , Adjustable t m
     )
  => Ghci t
  -> VtyWidget t m ()
ghciModuleStatus :: Ghci t -> VtyWidget t m ()
ghciModuleStatus g :: Ghci t
g = Layout t m () -> VtyWidget t m ()
forall (m :: * -> *) t a.
(MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m) =>
Layout t m a -> VtyWidget t m a
col (Layout t m () -> VtyWidget t m ())
-> Layout t m () -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ do
  let ghciExit :: Event t ExitCode
ghciExit = Process t ByteString ByteString -> Event t ExitCode
forall t o e. Process t o e -> Event t ExitCode
_process_exit (Process t ByteString ByteString -> Event t ExitCode)
-> Process t ByteString ByteString -> Event t ExitCode
forall a b. (a -> b) -> a -> b
$ Ghci t -> Process t ByteString ByteString
forall t. Ghci t -> Process t ByteString ByteString
_ghci_process Ghci t
g
  Behavior t Bool
ghciExited <- Bool -> Event t Bool -> Layout t m (Behavior t Bool)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold Bool
False (Event t Bool -> Layout t m (Behavior t Bool))
-> Event t Bool -> Layout t m (Behavior t Bool)
forall a b. (a -> b) -> a -> b
$ Bool
True Bool -> Event t ExitCode -> Event t Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ExitCode
ghciExit
  Dynamic t Int -> VtyWidget t m () -> Layout t m ()
forall t (m :: * -> *) a.
(Reflex t, Monad m, MonadNodeId m) =>
Dynamic t Int -> VtyWidget t m a -> Layout t m a
fixed 3 (VtyWidget t m () -> Layout t m ())
-> VtyWidget t m () -> Layout t m ()
forall a b. (a -> b) -> a -> b
$ BoxStyle -> VtyWidget t m () -> VtyWidget t m ()
forall t (m :: * -> *) a.
(Reflex t, Monad m, MonadNodeId m) =>
BoxStyle -> VtyWidget t m a -> VtyWidget t m a
boxStatic BoxStyle
forall a. Default a => a
def (VtyWidget t m () -> VtyWidget t m ())
-> VtyWidget t m () -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ Ghci t -> VtyWidget t m ()
forall t (m :: * -> *).
(PostBuild t m, MonadHold t m) =>
Ghci t -> VtyWidget t m ()
statusDisplay Ghci t
g
  Dynamic t ByteString
out <- Behavior t Bool -> Ghci t -> Layout t m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
moduleOutput (Bool -> Bool
not (Bool -> Bool) -> Behavior t Bool -> Behavior t Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Bool
ghciExited) Ghci t
g
  VtyWidget t m () -> Layout t m ()
forall t (m :: * -> *) a.
(Reflex t, Monad m, MonadNodeId m) =>
VtyWidget t m a -> Layout t m a
stretch (VtyWidget t m () -> Layout t m ())
-> VtyWidget t m () -> Layout t m ()
forall a b. (a -> b) -> a -> b
$ VtyWidget t m (Dynamic t ()) -> VtyWidget t m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (VtyWidget t m (Dynamic t ()) -> VtyWidget t m ())
-> VtyWidget t m (Dynamic t ()) -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$
    VtyWidget t m ()
-> Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ())
forall t (m :: * -> *) a.
(Adjustable t m, MonadHold t m) =>
m a -> Event t (m a) -> m (Dynamic t a)
networkHold (Behavior t ByteString -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, MonadNodeId m, MonadHold t m, MonadFix m,
 PostBuild t m) =>
Behavior t ByteString -> VtyWidget t m ()
scrollableOutput (Behavior t ByteString -> VtyWidget t m ())
-> Behavior t ByteString -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ Dynamic t ByteString -> Behavior t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t ByteString
out) (Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ()))
-> Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ())
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> VtyWidget t m ()) -> Event t (VtyWidget t m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Ghci t -> Event t ()
forall t. Ghci t -> Event t ()
_ghci_reload Ghci t
g) ((() -> VtyWidget t m ()) -> Event t (VtyWidget t m ()))
-> (() -> VtyWidget t m ()) -> Event t (VtyWidget t m ())
forall a b. (a -> b) -> a -> b
$
      VtyWidget t m () -> () -> VtyWidget t m ()
forall a b. a -> b -> a
const (VtyWidget t m () -> () -> VtyWidget t m ())
-> VtyWidget t m () -> () -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ Behavior t ByteString -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, MonadNodeId m, MonadHold t m, MonadFix m,
 PostBuild t m) =>
Behavior t ByteString -> VtyWidget t m ()
scrollableOutput (Behavior t ByteString -> VtyWidget t m ())
-> Behavior t ByteString -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ Dynamic t ByteString -> Behavior t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t ByteString
out

-- | Display the output of the expression GHCi is evaluating
ghciExecOutput
  :: ( MonadHold t m
     , MonadFix m
     , Adjustable t m
     )
  => Ghci t
  -> VtyWidget t m ()
ghciExecOutput :: Ghci t -> VtyWidget t m ()
ghciExecOutput g :: Ghci t
g = do
  Behavior t Bool
ghciExited <- Bool -> Event t Bool -> VtyWidget t m (Behavior t Bool)
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold Bool
False (Event t Bool -> VtyWidget t m (Behavior t Bool))
-> Event t Bool -> VtyWidget t m (Behavior t Bool)
forall a b. (a -> b) -> a -> b
$ Bool
True Bool -> Event t ExitCode -> Event t Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Process t ByteString ByteString -> Event t ExitCode
forall t o e. Process t o e -> Event t ExitCode
_process_exit (Ghci t -> Process t ByteString ByteString
forall t. Ghci t -> Process t ByteString ByteString
_ghci_process Ghci t
g)
  Dynamic t ByteString
out <- Behavior t Bool -> Ghci t -> VtyWidget t m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
execOutput (Bool -> Bool
not (Bool -> Bool) -> Behavior t Bool -> Behavior t Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Bool
ghciExited) Ghci t
g
  -- Rebuild the entire output widget so that we don't have to worry about resetting scroll state
  Dynamic t ()
_ <- VtyWidget t m ()
-> Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ())
forall t (m :: * -> *) a.
(Adjustable t m, MonadHold t m) =>
m a -> Event t (m a) -> m (Dynamic t a)
networkHold (Dynamic t ByteString -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m, MonadHold t m, MonadFix m) =>
Dynamic t ByteString -> VtyWidget t m ()
scrollingOutput Dynamic t ByteString
out) (Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ()))
-> Event t (VtyWidget t m ()) -> VtyWidget t m (Dynamic t ())
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> VtyWidget t m ()) -> Event t (VtyWidget t m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Ghci t -> Event t ()
forall t. Ghci t -> Event t ()
_ghci_reload Ghci t
g) ((() -> VtyWidget t m ()) -> Event t (VtyWidget t m ()))
-> (() -> VtyWidget t m ()) -> Event t (VtyWidget t m ())
forall a b. (a -> b) -> a -> b
$ \_ -> Dynamic t ByteString -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m, MonadHold t m, MonadFix m) =>
Dynamic t ByteString -> VtyWidget t m ()
scrollingOutput Dynamic t ByteString
out
  () -> VtyWidget t m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | A widget that displays the module status and the execution status in two stacked, resizable panes
ghciPanes
  :: ( Reflex t
     , MonadFix m
     , MonadHold t m
     , MonadNodeId m
     , PostBuild t m
     , Adjustable t m
     )
  => Ghci t
  -> VtyWidget t m ()
ghciPanes :: Ghci t -> VtyWidget t m ()
ghciPanes g :: Ghci t
g = VtyWidget t m ((), ()) -> VtyWidget t m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (VtyWidget t m ((), ()) -> VtyWidget t m ())
-> VtyWidget t m ((), ()) -> VtyWidget t m ()
forall a b. (a -> b) -> a -> b
$ VtyWidget t m ()
-> VtyWidget t m () -> VtyWidget t m () -> VtyWidget t m ((), ())
forall t (m :: * -> *) a b.
(Reflex t, MonadFix m, MonadHold t m, MonadNodeId m) =>
VtyWidget t m ()
-> VtyWidget t m a -> VtyWidget t m b -> VtyWidget t m (a, b)
splitVDrag
  (BoxStyle -> VtyWidget t m ()
forall t (m :: * -> *).
(Reflex t, Monad m) =>
BoxStyle -> VtyWidget t m ()
hRule BoxStyle
doubleBoxStyle)
  (Ghci t -> VtyWidget t m ()
forall (m :: * -> *) t.
(MonadNodeId m, PostBuild t m, MonadHold t m, MonadFix m,
 Adjustable t m) =>
Ghci t -> VtyWidget t m ()
ghciModuleStatus Ghci t
g)
  (Ghci t -> VtyWidget t m ()
forall t (m :: * -> *).
(MonadHold t m, MonadFix m, Adjustable t m) =>
Ghci t -> VtyWidget t m ()
ghciExecOutput Ghci t
g)

-- | Listen for ctrl-c (and any other provided exit events) and
-- shutdown the Ghci process upon receipt
getExitEvent
  :: ( PerformEvent t m
     , MonadIO (Performable m)
     )
  => Ghci t
  -> Event t a
  -> VtyWidget t m (Event t ())
getExitEvent :: Ghci t -> Event t a -> VtyWidget t m (Event t ())
getExitEvent g :: Ghci t
g externalExitReq :: Event t a
externalExitReq = do
  Event t KeyCombo
exitReq <- KeyCombo -> VtyWidget t m (Event t KeyCombo)
forall t (m :: * -> *).
(Reflex t, Monad m) =>
KeyCombo -> VtyWidget t m (Event t KeyCombo)
keyCombo (Char -> Key
V.KChar 'c', [Modifier
V.MCtrl])
  let exitReqs :: Event t (Ghci t)
exitReqs = [Event t (Ghci t)] -> Event t (Ghci t)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
        [ Ghci t
g Ghci t -> Event t a -> Event t (Ghci t)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t a
externalExitReq
        , Ghci t
g Ghci t -> Event t KeyCombo -> Event t (Ghci t)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
exitReq
        ]
  Event t (Ghci t) -> VtyWidget t m (Event t ())
forall t (m :: * -> *).
(PerformEvent t m, MonadIO (Performable m)) =>
Event t (Ghci t) -> m (Event t ())
shutdown Event t (Ghci t)
exitReqs

-- | Shut down a given Ghci process
shutdown
  :: ( PerformEvent t m
     , MonadIO (Performable m)
     )
  => Event t (Ghci t)
  -> m (Event t ())
shutdown :: Event t (Ghci t) -> m (Event t ())
shutdown exitReqs :: Event t (Ghci t)
exitReqs = do
  Event t (Performable m ()) -> m (Event t ())
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m ()) -> m (Event t ()))
-> Event t (Performable m ()) -> m (Event t ())
forall a b. (a -> b) -> a -> b
$ Event t (Ghci t)
-> (Ghci t -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t (Ghci t)
exitReqs ((Ghci t -> Performable m ()) -> Event t (Performable m ()))
-> (Ghci t -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \g :: Ghci t
g ->
    IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
P.terminateProcess (ProcessHandle -> IO ()) -> ProcessHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> ProcessHandle
forall t o e. Process t o e -> ProcessHandle
_process_handle (Process t ByteString ByteString -> ProcessHandle)
-> Process t ByteString ByteString -> ProcessHandle
forall a b. (a -> b) -> a -> b
$ Ghci t -> Process t ByteString ByteString
forall t. Ghci t -> Process t ByteString ByteString
_ghci_process Ghci t
g