{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Reflex.Process.GHCi
( ghci
, ghciWatch
, Ghci(..)
, Status(..)
, moduleOutput
, execOutput
, collectOutput
, statusMessage
) where
import Reflex
import Reflex.FSNotify (watchDirectoryTree)
import Reflex.Process (ProcessConfig(..), Process(..), SendPipe(..), createProcess)
import Control.Monad ((<=<))
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.String (IsString)
import System.Directory (getCurrentDirectory)
import qualified System.FSNotify as FS
import System.FilePath.Posix (takeExtension)
import qualified System.Info as Sys
import System.Posix.Signals (sigINT)
import qualified System.Process as P
import qualified Text.Regex.TDFA as Regex ((=~))
msg :: (IsString a, Semigroup a) => a -> a
msg :: a -> a
msg = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) a
"<reflex-ghci>: "
ghci
:: ( TriggerEvent t m
, PerformEvent t m
, MonadIO (Performable m)
, PostBuild t m
, MonadIO m
, MonadFix m
, MonadHold t m
)
=> P.CreateProcess
-> Maybe ByteString
-> Event t ()
-> m (Ghci t)
ghci :: CreateProcess -> Maybe ByteString -> Event t () -> m (Ghci t)
ghci CreateProcess
cmd Maybe ByteString
mexpr Event t ()
reloadReq = do
let msgInit :: ByteString
msgInit = ByteString -> ByteString
forall a. (IsString a, Semigroup a) => a -> a
msg ByteString
"performing setup..."
msgExprStarted :: ByteString
msgExprStarted = ByteString -> ByteString
forall a. (IsString a, Semigroup a) => a -> a
msg ByteString
"evaluating expression..."
msgExprFinished :: ByteString
msgExprFinished = ByteString -> ByteString
forall a. (IsString a, Semigroup a) => a -> a
msg ByteString
"expression evaluation ended."
putMsgLn :: ByteString -> ByteString
putMsgLn :: ByteString -> ByteString
putMsgLn ByteString
m = ByteString
"Prelude.putStrLn \"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
m ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\"\n"
rec Process t ByteString ByteString
proc <- CreateProcess
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
forall (m :: * -> *) t.
(MonadIO m, TriggerEvent t m, PerformEvent t m,
MonadIO (Performable m), MonadFix m) =>
CreateProcess
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
createProcess CreateProcess
cmd (ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString))
-> ProcessConfig t (SendPipe ByteString)
-> m (Process t ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ ProcessConfig :: forall t i. Event t i -> Event t Signal -> ProcessConfig t i
ProcessConfig
{ _processConfig_stdin :: Event t (SendPipe ByteString)
_processConfig_stdin = ByteString -> SendPipe ByteString
forall i. i -> SendPipe i
SendPipe_Message (ByteString -> SendPipe ByteString)
-> (ByteString -> ByteString) -> ByteString -> SendPipe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") (ByteString -> SendPipe ByteString)
-> Event t ByteString -> Event t (SendPipe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event t ByteString] -> Event t ByteString
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
[ Event t ByteString
reload
, Event t Status
-> (Status -> Maybe ByteString) -> Event t ByteString
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (Dynamic t Status -> Event t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t Status
status) ((Status -> Maybe ByteString) -> Event t ByteString)
-> (Status -> Maybe ByteString) -> Event t ByteString
forall a b. (a -> b) -> a -> b
$ \case
Status
Status_LoadSucceeded -> Maybe ByteString -> (ByteString -> ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Maybe ByteString
mexpr ((ByteString -> ByteString) -> Maybe ByteString)
-> (ByteString -> ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
expr ->
ByteString -> [ByteString] -> ByteString
C8.intercalate ByteString
"\n"
[ ByteString -> ByteString
putMsgLn ByteString
msgExprStarted
, ByteString -> ByteString
putMsgLn ByteString
expr
, ByteString
expr
, ByteString -> ByteString
putMsgLn ByteString
msgExprFinished
]
Status
_ -> Maybe ByteString
forall a. Maybe a
Nothing
, let f :: Status -> Status -> Maybe ByteString
f Status
old Status
new = if Status
old Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Status_Initializing Bool -> Bool -> Bool
&& Status
new Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Status_Loading
then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
C8.intercalate ByteString
"\n"
[ ByteString -> ByteString
putMsgLn ByteString
msgInit
, ByteString
":set prompt ..."
, ByteString
":set -fno-break-on-exception"
, ByteString
":set -fno-break-on-error"
, ByteString
":set prompt \"\""
, ByteString -> ByteString
putMsgLn ByteString
""
, ByteString
":set prompt " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
forall a. IsString a => a
prompt
, ByteString
":r"
]
else Maybe ByteString
forall a. Maybe a
Nothing
in (Status -> Status -> Maybe ByteString)
-> Behavior t Status -> Event t Status -> Event t ByteString
forall k (t :: k) a b c.
Reflex t =>
(a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
attachWithMaybe Status -> Status -> Maybe ByteString
f (Dynamic t Status -> Behavior t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Status
status) (Dynamic t Status -> Event t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t Status
status)
]
, _processConfig_signal :: Event t Signal
_processConfig_signal = Signal
sigINT Signal -> Event t () -> Event t Signal
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
requestInterrupt
}
let reload :: Event t ByteString
reload = [Event t ByteString] -> Event t ByteString
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
[ ByteString
":r" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
reloadReq
]
Dynamic t ByteString
output <- Event t () -> Event t ByteString -> m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput (() () -> Event t ByteString -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ByteString
reload) (Event t ByteString -> m (Dynamic t ByteString))
-> Event t ByteString -> m (Dynamic t ByteString)
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t o
_process_stdout Process t ByteString ByteString
proc
Dynamic t ByteString
errors <- Event t () -> Event t ByteString -> m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput (() () -> Event t ByteString -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ByteString
reload) (Event t ByteString -> m (Dynamic t ByteString))
-> Event t ByteString -> m (Dynamic t ByteString)
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t e
_process_stderr Process t ByteString ByteString
proc
let interruptible :: Status -> Bool
interruptible Status
s = Status
s Status -> [Status] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Status
Status_Loading, Status
Status_Executing]
requestInterrupt :: Event t ()
requestInterrupt = Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate (Status -> Bool
interruptible (Status -> Bool) -> Behavior t Status -> Behavior t Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Status -> Behavior t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Status
status) (() () -> Event t () -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
reloadReq)
let okModulesLoaded :: ByteString
okModulesLoaded = ByteString
"Ok.*module.*loaded." :: ByteString
failedNoModulesLoaded :: ByteString
failedNoModulesLoaded = ByteString
"Failed,.*module.*loaded." :: ByteString
exceptionMessage :: ByteString
exceptionMessage = ByteString
"\\*\\*\\* Exception:.*" :: ByteString
interactiveErrorMessage :: ByteString
interactiveErrorMessage = ByteString
"<interactive>:.*:.*:.error:.*" :: ByteString
ghciVersionMessage :: ByteString
ghciVersionMessage = ByteString
"GHCi, version.*: https?://www.haskell.org/ghc/" :: ByteString
Dynamic t Status
status :: Dynamic t Status <- Dynamic t Status -> m (Dynamic t Status)
forall k (t :: k) (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m, Eq a) =>
Dynamic t a -> m (Dynamic t a)
holdUniqDyn (Dynamic t Status -> m (Dynamic t Status))
-> (Event t (Status -> Status) -> m (Dynamic t Status))
-> Event t (Status -> Status)
-> m (Dynamic t Status)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((Status -> Status) -> Status -> Status)
-> Status -> Event t (Status -> Status) -> m (Dynamic t Status)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (Status -> Status) -> Status -> Status
forall a b. (a -> b) -> a -> b
($) Status
Status_Initializing (Event t (Status -> Status) -> m (Dynamic t Status))
-> Event t (Status -> Status) -> m (Dynamic t Status)
forall a b. (a -> b) -> a -> b
$ [Event t (Status -> Status)] -> Event t (Status -> Status)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
[ Event t ByteString
-> (ByteString -> Maybe (Status -> Status))
-> Event t (Status -> Status)
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (Dynamic t ByteString -> Event t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t ByteString
errors) ((ByteString -> Maybe (Status -> Status))
-> Event t (Status -> Status))
-> (ByteString -> Maybe (Status -> Status))
-> Event t (Status -> Status)
forall a b. (a -> b) -> a -> b
$ \ByteString
err -> if ByteString
err ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
exceptionMessage Bool -> Bool -> Bool
|| ByteString
err ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
interactiveErrorMessage
then (Status -> Status) -> Maybe (Status -> Status)
forall a. a -> Maybe a
Just ((Status -> Status) -> Maybe (Status -> Status))
-> (Status -> Status) -> Maybe (Status -> Status)
forall a b. (a -> b) -> a -> b
$ Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_ExecutionFailed
else Maybe (Status -> Status)
forall a. Maybe a
Nothing
, Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_Loading (Status -> Status)
-> Event t ByteString -> Event t (Status -> Status)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ByteString
reload
, Event t ByteString
-> (ByteString -> Status -> Status) -> Event t (Status -> Status)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Dynamic t ByteString -> Event t ByteString
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t ByteString
output) ((ByteString -> Status -> Status) -> Event t (Status -> Status))
-> (ByteString -> Status -> Status) -> Event t (Status -> Status)
forall a b. (a -> b) -> a -> b
$ \ByteString
out -> case [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString -> [ByteString]
C8.lines ByteString
out) of
ByteString
lastLine:ByteString
expectedMessage:[ByteString]
_
| ByteString
lastLine ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. IsString a => a
prompt Bool -> Bool -> Bool
&& ByteString
expectedMessage ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
okModulesLoaded -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_LoadSucceeded
| ByteString
lastLine ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. IsString a => a
prompt Bool -> Bool -> Bool
&& ByteString
expectedMessage ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
failedNoModulesLoaded -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_LoadFailed
| ByteString
lastLine ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. IsString a => a
prompt Bool -> Bool -> Bool
&& ByteString
expectedMessage ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
msgExprStarted -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_Executing
| ByteString
lastLine ByteString -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ (String
forall a. IsString a => a
prompt :: String) Bool -> Bool -> Bool
&& ByteString
expectedMessage ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
msgExprFinished -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_ExecutionSucceeded
| ByteString
lastLine ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
ghciVersionMessage -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_Loading
| Bool
otherwise -> \case
Status
Status_LoadSucceeded -> case Maybe ByteString
mexpr of
Maybe ByteString
Nothing -> Status
Status_LoadSucceeded
Just ByteString
_ -> Status
Status_Executing
Status
s -> Status
s
ByteString
lastLine:[ByteString]
_
| ByteString
lastLine ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
ghciVersionMessage -> Status -> Status -> Status
forall a b. a -> b -> a
const Status
Status_Loading
[ByteString]
_ -> Status -> Status
forall a. a -> a
id
]
Behavior t Bool
execStream <- Bool -> Event t Bool -> 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 -> m (Behavior t Bool))
-> Event t Bool -> m (Behavior t Bool)
forall a b. (a -> b) -> a -> b
$ [Event t Bool] -> Event t Bool
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
[ Bool
False Bool -> Event t ByteString -> Event t Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ByteString
reload
, Event t Status -> (Status -> Maybe Bool) -> Event t Bool
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (Dynamic t Status -> Event t Status
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t Status
status) ((Status -> Maybe Bool) -> Event t Bool)
-> (Status -> Maybe Bool) -> Event t Bool
forall a b. (a -> b) -> a -> b
$ \case
Status
Status_LoadSucceeded -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Status
Status_LoadFailed -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
Status
Status_Executing -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Status
_ -> Maybe Bool
forall a. Maybe a
Nothing
]
Ghci t -> m (Ghci t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ghci t -> m (Ghci t)) -> Ghci t -> m (Ghci t)
forall a b. (a -> b) -> a -> b
$ Ghci :: forall t.
Event t ByteString
-> Event t ByteString
-> Event t ByteString
-> Event t ByteString
-> Event t ()
-> Dynamic t Status
-> Process t ByteString ByteString
-> Ghci t
Ghci
{ _ghci_moduleOut :: Event t ByteString
_ghci_moduleOut = Behavior t Bool -> Event t ByteString -> Event t ByteString
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
<$> Behavior t Bool
execStream) (Event t ByteString -> Event t ByteString)
-> Event t ByteString -> Event t ByteString
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t o
_process_stdout Process t ByteString ByteString
proc
, _ghci_moduleErr :: Event t ByteString
_ghci_moduleErr = Behavior t Bool -> Event t ByteString -> Event t ByteString
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
<$> Behavior t Bool
execStream) (Event t ByteString -> Event t ByteString)
-> Event t ByteString -> Event t ByteString
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t e
_process_stderr Process t ByteString ByteString
proc
, _ghci_execOut :: Event t ByteString
_ghci_execOut = Behavior t Bool -> Event t ByteString -> Event t ByteString
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate Behavior t Bool
execStream (Event t ByteString -> Event t ByteString)
-> Event t ByteString -> Event t ByteString
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t o
_process_stdout Process t ByteString ByteString
proc
, _ghci_execErr :: Event t ByteString
_ghci_execErr = Behavior t Bool -> Event t ByteString -> Event t ByteString
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate Behavior t Bool
execStream (Event t ByteString -> Event t ByteString)
-> Event t ByteString -> Event t ByteString
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> Event t ByteString
forall t o e. Process t o e -> Event t e
_process_stderr Process t ByteString ByteString
proc
, _ghci_reload :: Event t ()
_ghci_reload = () () -> Event t ByteString -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ByteString
reload
, _ghci_status :: Dynamic t Status
_ghci_status = Dynamic t Status
status
, _ghci_process :: Process t ByteString ByteString
_ghci_process = Process t ByteString ByteString
proc
}
where
prompt :: IsString a => a
prompt :: a
prompt = a
"<| Waiting |>"
ghciWatch
:: ( TriggerEvent t m
, PerformEvent t m
, MonadIO (Performable m)
, PostBuild t m
, MonadIO m
, MonadFix m
, MonadHold t m
)
=> P.CreateProcess
-> Maybe ByteString
-> m (Ghci t)
ghciWatch :: CreateProcess -> Maybe ByteString -> m (Ghci t)
ghciWatch CreateProcess
p Maybe ByteString
mexec = 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 -> WatchConfig
noDebounce (WatchConfig -> WatchConfig) -> WatchConfig -> WatchConfig
forall a b. (a -> b) -> a -> b
$ WatchConfig
FS.defaultConfig
{ confUsePolling :: Bool
FS.confUsePolling = String
Sys.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"darwin"
, confPollInterval :: Int
FS.confPollInterval = Int
250000
}
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.1 Event t FSEvent
fsEvents
CreateProcess -> Maybe ByteString -> Event t () -> m (Ghci t)
forall t (m :: * -> *).
(TriggerEvent t m, PerformEvent t m, MonadIO (Performable m),
PostBuild t m, MonadIO m, MonadFix m, MonadHold t m) =>
CreateProcess -> Maybe ByteString -> Event t () -> m (Ghci t)
ghci CreateProcess
p Maybe ByteString
mexec (Event t () -> m (Ghci t)) -> Event t () -> m (Ghci t)
forall a b. (a -> b) -> a -> b
$ () () -> Event t (Seq FSEvent) -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t (Seq FSEvent)
batchedFsEvents
where
noDebounce :: FS.WatchConfig -> FS.WatchConfig
noDebounce :: WatchConfig -> WatchConfig
noDebounce WatchConfig
cfg = WatchConfig
cfg { confDebounce :: Debounce
FS.confDebounce = Debounce
FS.NoDebounce }
data Ghci t = Ghci
{ Ghci t -> Event t ByteString
_ghci_moduleOut :: Event t ByteString
, Ghci t -> Event t ByteString
_ghci_moduleErr :: Event t ByteString
, Ghci t -> Event t ByteString
_ghci_execOut :: Event t ByteString
, Ghci t -> Event t ByteString
_ghci_execErr :: Event t ByteString
, Ghci t -> Event t ()
_ghci_reload :: Event t ()
, Ghci t -> Dynamic t Status
_ghci_status :: Dynamic t Status
, Ghci t -> Process t ByteString ByteString
_ghci_process :: Process t ByteString ByteString
}
data Status
= Status_Initializing
| Status_Loading
| Status_LoadFailed
| Status_LoadSucceeded
| Status_Executing
| Status_ExecutionFailed
| Status_ExecutionSucceeded
deriving (Int -> Status -> String -> String
[Status] -> String -> String
Status -> String
(Int -> Status -> String -> String)
-> (Status -> String)
-> ([Status] -> String -> String)
-> Show Status
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Status] -> String -> String
$cshowList :: [Status] -> String -> String
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> String -> String
$cshowsPrec :: Int -> Status -> String -> String
Show, ReadPrec [Status]
ReadPrec Status
Int -> ReadS Status
ReadS [Status]
(Int -> ReadS Status)
-> ReadS [Status]
-> ReadPrec Status
-> ReadPrec [Status]
-> Read Status
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Status]
$creadListPrec :: ReadPrec [Status]
readPrec :: ReadPrec Status
$creadPrec :: ReadPrec Status
readList :: ReadS [Status]
$creadList :: ReadS [Status]
readsPrec :: Int -> ReadS Status
$creadsPrec :: Int -> ReadS Status
Read, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Eq Status
Eq Status
-> (Status -> Status -> Ordering)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Status)
-> (Status -> Status -> Status)
-> Ord Status
Status -> Status -> Bool
Status -> Status -> Ordering
Status -> Status -> Status
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 :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmax :: Status -> Status -> Status
>= :: Status -> Status -> Bool
$c>= :: Status -> Status -> Bool
> :: Status -> Status -> Bool
$c> :: Status -> Status -> Bool
<= :: Status -> Status -> Bool
$c<= :: Status -> Status -> Bool
< :: Status -> Status -> Bool
$c< :: Status -> Status -> Bool
compare :: Status -> Status -> Ordering
$ccompare :: Status -> Status -> Ordering
$cp1Ord :: Eq Status
Ord)
moduleOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Behavior t Bool
-> Ghci t
-> m (Dynamic t ByteString)
moduleOutput :: Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
moduleOutput Behavior t Bool
clear Ghci t
g = Event t () -> Event t ByteString -> m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput
(Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate Behavior t Bool
clear (Event t () -> Event t ()) -> Event t () -> Event t ()
forall a b. (a -> b) -> a -> b
$ () () -> Event t () -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ghci t -> Event t ()
forall t. Ghci t -> Event t ()
_ghci_reload Ghci t
g) (Event t ByteString -> m (Dynamic t ByteString))
-> Event t ByteString -> m (Dynamic t ByteString)
forall a b. (a -> b) -> a -> b
$
[Event t ByteString] -> Event t ByteString
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Ghci t -> Event t ByteString
forall t. Ghci t -> Event t ByteString
_ghci_moduleOut Ghci t
g, Ghci t -> Event t ByteString
forall t. Ghci t -> Event t ByteString
_ghci_moduleErr Ghci t
g]
execOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Behavior t Bool
-> Ghci t
-> m (Dynamic t ByteString)
execOutput :: Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
execOutput Behavior t Bool
clear Ghci t
g = Event t () -> Event t ByteString -> m (Dynamic t ByteString)
forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m) =>
Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput
(Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate Behavior t Bool
clear (Event t () -> Event t ()) -> Event t () -> Event t ()
forall a b. (a -> b) -> a -> b
$ () () -> Event t () -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ghci t -> Event t ()
forall t. Ghci t -> Event t ()
_ghci_reload Ghci t
g) (Event t ByteString -> m (Dynamic t ByteString))
-> Event t ByteString -> m (Dynamic t ByteString)
forall a b. (a -> b) -> a -> b
$
[Event t ByteString] -> Event t ByteString
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Ghci t -> Event t ByteString
forall t. Ghci t -> Event t ByteString
_ghci_execOut Ghci t
g, Ghci t -> Event t ByteString
forall t. Ghci t -> Event t ByteString
_ghci_execErr Ghci t
g]
collectOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Event t ()
-> Event t ByteString
-> m (Dynamic t ByteString)
collectOutput :: Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput Event t ()
clear Event t ByteString
out = ((ByteString -> ByteString) -> ByteString -> ByteString)
-> ByteString
-> Event t (ByteString -> ByteString)
-> m (Dynamic t ByteString)
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
($) ByteString
"" (Event t (ByteString -> ByteString) -> m (Dynamic t ByteString))
-> Event t (ByteString -> ByteString) -> m (Dynamic t ByteString)
forall a b. (a -> b) -> a -> b
$ [Event t (ByteString -> ByteString)]
-> Event t (ByteString -> ByteString)
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
[ (ByteString -> ByteString -> ByteString)
-> ByteString -> ByteString -> ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend (ByteString -> ByteString -> ByteString)
-> Event t ByteString -> Event t (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t ByteString
out
, ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString
"" (ByteString -> ByteString)
-> Event t () -> Event t (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
clear
]
statusMessage :: IsString a => Status -> a
statusMessage :: Status -> a
statusMessage = \case
Status
Status_Initializing -> a
"Initializing..."
Status
Status_Loading -> a
"Loading Modules..."
Status
Status_LoadFailed -> a
"Failed to Load Modules!"
Status
Status_LoadSucceeded -> a
"Successfully Loaded Modules!"
Status
Status_Executing -> a
"Executing Command..."
Status
Status_ExecutionFailed -> a
"Command Failed!"
Status
Status_ExecutionSucceeded -> a
"Command Succeeded!"