{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Reflex.Process.GHCi
( ghci
, ghciWatch
, module X
, hasErrors
) where
import Reflex
import Reflex.FSNotify (watchDirectoryTree)
import Reflex.Process (Process(..))
import Control.Monad
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import qualified Data.Map as Map
import System.Directory (getCurrentDirectory)
import qualified System.FSNotify as FS
import System.FilePath.Posix (takeExtension)
import qualified System.Info as Sys
import qualified System.Posix.Signals as Signals
import qualified System.Process as P
import qualified Text.Regex.TDFA as Regex ((=~))
import Reflex.Process.Repl as X
ghci
:: ( Adjustable t m
, MonadFix m
, MonadHold t m
, MonadIO (Performable m)
, MonadIO m
, NotReady t m
, PerformEvent t m
, PostBuild t m
, TriggerEvent t m
)
=> P.CreateProcess
-> Event t [Command]
-> Event t ()
-> Event t ()
-> m (Repl t)
ghci :: CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
ghci CreateProcess
runGhci Event t [Command]
expr Event t ()
reload Event t ()
shutdown = do
Handler
_ <- IO Handler -> m Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigINT (IO () -> Handler
Signals.Catch (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Maybe SignalSet
forall a. Maybe a
Nothing
Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
rec
r :: Repl t
r@(Repl Process t ByteString ByteString
proc Event t (Map Int Cmd)
_finished Dynamic t (Int, Maybe Cmd)
started Event t ExitCode
exit) <- CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
forall t (m :: * -> *).
(Adjustable t m, MonadFix m, MonadHold t m,
MonadIO (Performable m), MonadIO m, NotReady t m, PerformEvent t m,
PostBuild t m, TriggerEvent t m) =>
CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
repl CreateProcess
runGhci Event t [Command]
inputs Int -> ByteString -> Bool
forall a. Show a => a -> ByteString -> Bool
isPrompt
let inputs :: Event t [Command]
inputs = ([Command] -> [Command] -> [Command])
-> [Event t [Command]] -> Event t [Command]
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
(<>)
[ [ByteString] -> [Command]
commands [ByteString]
setupCommands [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb
, ByteString -> [Command]
command ByteString
":r" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
interrupted
, ByteString -> [Command]
command ByteString
":r" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
reload'
, ByteString -> [Command]
command ByteString
":q" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
shutdown
, Event t [Command]
expr
]
let interruptible :: Dynamic t Bool
interruptible = Dynamic t (Int, Maybe Cmd)
-> ((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t (Int, Maybe Cmd)
started (((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool)
-> ((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool
forall a b. (a -> b) -> a -> b
$ \case
(Int
_, Maybe Cmd
Nothing) -> Bool
False
(Int, Maybe Cmd)
_ -> Bool
True
Event t ()
reloadThrottled <- NominalDiffTime -> Event t () -> m (Event t ())
forall (m :: * -> *) t a.
(MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m,
MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
throttle NominalDiffTime
0.1 Event t ()
reload
let reload' :: Event t ()
reload' = Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate (Bool -> Bool
not (Bool -> Bool) -> Behavior t Bool -> Behavior t Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
interruptible) Event t ()
reloadThrottled
Event t ()
interrupted <- 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 ()
-> (() -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate (Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
interruptible) Event t ()
reloadThrottled) ((() -> Performable m ()) -> Event t (Performable m ()))
-> (() -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
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.interruptProcessGroupOf (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
proc
Event t ()
forceShutdown <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
2 Event t ()
shutdown
Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ()
forceShutdown ((() -> Performable m ()) -> Event t (Performable m ()))
-> (() -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> 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
$ do
let h :: ProcessHandle
h = Process t ByteString ByteString -> ProcessHandle
forall t o e. Process t o e -> ProcessHandle
_process_handle Process t ByteString ByteString
proc
ProcessHandle -> IO ()
P.interruptProcessGroupOf ProcessHandle
h
ProcessHandle -> IO ()
P.terminateProcess ProcessHandle
h
Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ExitCode
-> (ExitCode -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ExitCode
exit ((ExitCode -> Performable m ()) -> Event t (Performable m ()))
-> (ExitCode -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \ExitCode
_ -> 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
$
IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigINT Handler
Signals.Default Maybe SignalSet
forall a. Maybe a
Nothing
Repl t -> m (Repl t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Repl t
r
where
promptPostfix :: ByteString
promptPostfix :: ByteString
promptPostfix = ByteString
"_reflex_ghci_prompt>"
isPrompt :: a -> ByteString -> Bool
isPrompt a
cur ByteString
line = (String -> ByteString
C8.pack (a -> String
forall a. Show a => a -> String
show a
cur) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
line
setupCommands :: [ByteString]
setupCommands =
[ ByteString
":set prompt-function \\_ x -> let s = \"\\n\" <> show x <> \"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\\n\" in System.IO.hPutStr System.IO.stderr s >> pure s"
, ByteString
":set -fno-break-on-exception"
, ByteString
":set -fno-break-on-error"
, ByteString
":set -v1"
, ByteString
":set -fno-hide-source-paths"
, ByteString
":set -ferror-spans"
, ByteString
":set -fdiagnostics-color=never"
, ByteString
":r"
]
hasErrors :: Cmd -> Bool
hasErrors :: Cmd -> Bool
hasErrors (Cmd Command
_ Lines
o Lines
e) =
let errs :: source1 -> Bool
errs source1
l =
source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
exceptionMessage Bool -> Bool -> Bool
||
source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
interactiveErrorMessage Bool -> Bool -> Bool
||
source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
moduleLoadError
errOnStderr :: Bool
errOnStderr = (ByteString -> Bool) -> Seq ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ByteString -> Bool
forall source1. RegexLike Regex source1 => source1 -> Bool
errs (Seq ByteString -> Bool) -> Seq ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Lines -> Seq ByteString
_lines_terminated Lines
e
errOnStdout :: Bool
errOnStdout = (ByteString -> Bool) -> Seq ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
failedModulesLoaded) (Seq ByteString -> Bool) -> Seq ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Lines -> Seq ByteString
_lines_terminated Lines
o
in Bool
errOnStderr Bool -> Bool -> Bool
|| Bool
errOnStdout
ghciWatch
:: ( TriggerEvent t m
, PerformEvent t m
, MonadIO (Performable m)
, PostBuild t m
, MonadIO m
, MonadFix m
, MonadHold t m
, Adjustable t m
, NotReady t m
)
=> P.CreateProcess
-> Maybe Command
-> Event t ()
-> Event t ()
-> m (Repl t)
ghciWatch :: CreateProcess
-> Maybe Command -> Event t () -> Event t () -> m (Repl t)
ghciWatch CreateProcess
p Maybe Command
mexpr Event t ()
reload Event t ()
shutdown = do
String
dir <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
let fsConfig :: WatchConfig
fsConfig = WatchConfig
FS.defaultConfig
{ confWatchMode :: WatchMode
FS.confWatchMode =
if String
Sys.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"darwin"
then Int -> WatchMode
FS.WatchModePoll Int
200000
else WatchMode
FS.WatchModeOS
}
Event t FSEvent
fsEvents <- WatchConfig
-> Event t String -> ActionPredicate -> m (Event t FSEvent)
forall t (m :: * -> *).
(Reflex t, TriggerEvent t m, PerformEvent t m,
MonadIO (Performable m)) =>
WatchConfig
-> Event t String -> ActionPredicate -> m (Event t FSEvent)
watchDirectoryTree WatchConfig
fsConfig (String
dir String -> Event t () -> Event t String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb) (ActionPredicate -> m (Event t FSEvent))
-> ActionPredicate -> m (Event t FSEvent)
forall a b. (a -> b) -> a -> b
$ \FSEvent
e ->
String -> String
takeExtension (FSEvent -> String
FS.eventPath FSEvent
e) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]
Event t (Seq FSEvent)
batchedFsEvents <- NominalDiffTime -> Event t FSEvent -> m (Event t (Seq FSEvent))
forall (m :: * -> *) t a.
(MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m,
MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t (Seq a))
batchOccurrences NominalDiffTime
0.05 Event t FSEvent
fsEvents
let reloadEvents :: Event t ()
reloadEvents = ((() () -> Event t (Seq FSEvent) -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t (Seq FSEvent)
batchedFsEvents) Event t () -> Event t () -> Event t ()
forall a. Semigroup a => a -> a -> a
<> Event t ()
reload)
rec Repl t
g <- CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
forall t (m :: * -> *).
(Adjustable t m, MonadFix m, MonadHold t m,
MonadIO (Performable m), MonadIO m, NotReady t m, PerformEvent t m,
PostBuild t m, TriggerEvent t m) =>
CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
ghci CreateProcess
p Event t [Command]
sendExpr Event t ()
reloadEvents Event t ()
shutdown
Event t [Command]
sendExpr <- NominalDiffTime -> Event t [Command] -> m (Event t [Command])
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
0.1 (Event t [Command] -> m (Event t [Command]))
-> Event t [Command] -> m (Event t [Command])
forall a b. (a -> b) -> a -> b
$ Event t (Map Int Cmd)
-> (Map Int Cmd -> Maybe [Command]) -> Event t [Command]
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (Repl t -> Event t (Map Int Cmd)
forall t. Repl t -> Event t (Map Int Cmd)
_repl_finished Repl t
g) ((Map Int Cmd -> Maybe [Command]) -> Event t [Command])
-> (Map Int Cmd -> Maybe [Command]) -> Event t [Command]
forall a b. (a -> b) -> a -> b
$ \Map Int Cmd
finished -> case [Cmd] -> [Cmd]
forall a. [a] -> [a]
reverse (Map Int Cmd -> [Cmd]
forall k a. Map k a -> [a]
Map.elems Map Int Cmd
finished) of
c :: Cmd
c@(Cmd Command
cmd Lines
_ Lines
_):[Cmd]
_ -> if Command -> ByteString
displayCommand Command
cmd ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
":r" Bool -> Bool -> Bool
&& Bool -> Bool
not (Cmd -> Bool
hasErrors Cmd
c)
then case Maybe Command
mexpr of
Maybe Command
Nothing -> Maybe [Command]
forall a. Maybe a
Nothing
Just Command
expr -> [Command] -> Maybe [Command]
forall a. a -> Maybe a
Just [Command
expr]
else Maybe [Command]
forall a. Maybe a
Nothing
[Cmd]
_ -> Maybe [Command]
forall a. Maybe a
Nothing
Repl t -> m (Repl t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Repl t
g
failedModulesLoaded :: ByteString
failedModulesLoaded :: ByteString
failedModulesLoaded = ByteString
"Failed,.*module.*loaded." :: ByteString
exceptionMessage :: ByteString
exceptionMessage :: ByteString
exceptionMessage = ByteString
"\\*\\*\\* Exception:.*" :: ByteString
interactiveErrorMessage :: ByteString
interactiveErrorMessage :: ByteString
interactiveErrorMessage = ByteString
"<interactive>:.*:.*:.error:.*" :: ByteString
moduleLoadError :: ByteString
moduleLoadError :: ByteString
moduleLoadError = ByteString
"^.+\\.(l)?hs:[0-9]+:[0-9]+: error:$"