{-|
 - Module: Reflex.Process.GHCi
 - Description: Run GHCi processes in a reflex application
-}
{-# 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 System.Posix.Signals (sigINT)
import qualified System.Process as P
import qualified Text.Regex.TDFA as Regex ((=~))

-- | Runs a GHCi process and reloads it whenever the provided event fires
ghci
  :: ( TriggerEvent t m
     , PerformEvent t m
     , MonadIO (Performable m)
     , PostBuild t m
     , MonadIO m
     , MonadFix m
     , MonadHold t m
     )
  => P.CreateProcess
  -- ^ Command to run to enter GHCi
  -> Maybe ByteString
  -- ^ Expression to evaluate whenever GHCi successfully loads modules
  -> Event t ()
  -- ^ Ask GHCi to reload
  -> m (Ghci t)
ghci :: CreateProcess -> Maybe ByteString -> Event t () -> m (Ghci t)
ghci cmd :: CreateProcess
cmd mexpr :: Maybe ByteString
mexpr reloadReq :: Event t ()
reloadReq = do
  -- Run the process and feed it some input:
  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)) =>
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
<> "\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
            -- Execute some expression if GHCi is ready to receive it
            , 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_LoadSucceeded -> Maybe ByteString
mexpr
                _ -> Maybe ByteString
forall a. Maybe a
Nothing
            -- On first load, set the prompt
            , let f :: Status -> Status -> Maybe ByteString
f old :: Status
old new :: 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 "\n"
                      [ "Prelude.putStrLn \"Initialized. Setting up reflex-ghci...\""
                      , ":set prompt ..."
                      , ":set -fno-break-on-exception"
                      , ":set -fno-break-on-error"
                      , ":set prompt \"\""
                      , "Prelude.putStrLn \"\""
                      , ":set prompt " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
forall a. IsString a => a
prompt
                      , ":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
        }

      -- Reload
      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
            [ ":r" ByteString -> Event t () -> Event t ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
reloadReq
            ]

      -- Capture and accumulate stdout and stderr between reloads.
      -- We'll inspect these values to determine GHCi's state
      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

     -- Only interrupt when there's a file change and we're ready and not in an idle state
      let interruptible :: Status -> Bool
interruptible s :: 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)

      -- Define some Regex patterns to use to determine GHCi's state based on output
      let okModulesLoaded :: ByteString
okModulesLoaded = "Ok.*module.*loaded." :: ByteString
          failedNoModulesLoaded :: ByteString
failedNoModulesLoaded = "Failed,.*module.*loaded." :: ByteString
          -- TODO: Is there a way to distinguish GHCi's actual exception output
          -- from someone printing "*** Exception:" to stderr?
          -- TODO: Are there other exception patterns to watch out for?
          exceptionMessage :: ByteString
exceptionMessage = "\\*\\*\\* Exception:.*" :: ByteString
          interactiveErrorMessage :: ByteString
interactiveErrorMessage = "<interactive>:.*:.*:.error:.*" :: ByteString
          -- We need to know when ghci is initialized enough that it won't die when
          -- it receives an interrupt. We wait to see the version line in the output as
          -- a proxy for GHCi's readiness to be interrupted
          ghciVersionMessage :: ByteString
ghciVersionMessage = "GHCi, version.*: https?://www.haskell.org/ghc/" :: ByteString


      -- Inspect the output and determine what state GHCi is in
      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
$ \err :: 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
$ \out :: ByteString
out -> case [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString -> [ByteString]
C8.lines ByteString
out) of
            lastLine :: ByteString
lastLine:expectedMessage :: ByteString
expectedMessage:_
              | 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 -> \case
                  Status_Executing -> Status
Status_ExecutionSucceeded
                  s :: Status
s -> Status
s
              | 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_LoadSucceeded -> case Maybe ByteString
mexpr of
                    Nothing -> Status
Status_LoadSucceeded
                    Just _ -> Status
Status_Executing
                  s :: Status
s -> Status
s

            lastLine :: ByteString
lastLine:_
              | 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
            _ -> Status -> Status
forall a. a -> a
id
        ]

  -- Determine when to switch output stream from GHCi module output to execution output
  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_LoadSucceeded -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
          Status_LoadFailed -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
          Status_Executing -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
          _ -> Maybe Bool
forall a. Maybe a
Nothing
      ]

  -- Below, we split up the output of the GHCi process into things that GHCi itself
  -- produces (e.g., errors, warnings, loading messages) and the output of the expression
  -- it is evaluating
  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 = "<| Waiting |>"

-- | Run a GHCi process that watches for changes to Haskell source files in the
-- current directory and reloads if they are modified
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 p :: CreateProcess
p mexec :: Maybe ByteString
mexec = do
  -- Get the current directory so we can observe changes in it
  FilePath
dir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory

  -- TODO: Separate the filesystem event logic into its own function
  -- Watch the project directory for changes
  Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  -- TODO Handle changes to "src" and ".cabal" differently. ":r" is only really appropriate
  -- when there are changes to loaded modules.
  -- We could use ":show modules" to see which hs files are loaded and determine what to do based
  -- on that, but we'll need to parse that output.

  Event t FSEvent
fsEvents <- WatchConfig
-> Event t FilePath -> ActionPredicate -> m (Event t FSEvent)
forall t (m :: * -> *).
(Reflex t, TriggerEvent t m, PerformEvent t m,
 MonadIO (Performable m)) =>
WatchConfig
-> Event t FilePath -> ActionPredicate -> m (Event t FSEvent)
watchDirectoryTree (WatchConfig -> WatchConfig
noDebounce WatchConfig
FS.defaultConfig) (FilePath
dir FilePath -> Event t () -> Event t FilePath
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
$ \e :: FSEvent
e ->
    FilePath -> FilePath
takeExtension (FSEvent -> FilePath
FS.eventPath FSEvent
e) FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [".hs", ".lhs"]

  -- Events are batched because otherwise we'd get several updates corresponding to one
  -- user-level change. For example, saving a file in vim results in an event claiming
  -- the file was removed followed almost immediately by an event adding the file
  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 0.1 Event t FSEvent
fsEvents

  -- Call GHCi and request a reload every time the files we're watching change
  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 cfg :: WatchConfig
cfg = WatchConfig
cfg { confDebounce :: Debounce
FS.confDebounce = Debounce
FS.NoDebounce }

-- | The output of the GHCi process
data Ghci t = Ghci
  { Ghci t -> Event t ByteString
_ghci_moduleOut :: Event t ByteString
  -- ^ stdout output produced when loading modules
  , Ghci t -> Event t ByteString
_ghci_moduleErr :: Event t ByteString
  -- ^ stderr output produced when loading modules
  , Ghci t -> Event t ByteString
_ghci_execOut :: Event t ByteString
  -- ^ stdout output produced while evaluating an expression
  , Ghci t -> Event t ByteString
_ghci_execErr :: Event t ByteString
  -- ^ stderr output produced while evaluating an expression
  , Ghci t -> Event t ()
_ghci_reload :: Event t ()
  -- ^ Event that fires when GHCi is reloading
  , Ghci t -> Dynamic t Status
_ghci_status :: Dynamic t Status
  -- ^ The current status of the GHCi process
  , Ghci t -> Process t ByteString ByteString
_ghci_process :: Process t ByteString ByteString
  }

-- | The state of the GHCi process
data Status
  = Status_Initializing
  | Status_Loading
  | Status_LoadFailed
  | Status_LoadSucceeded
  | Status_Executing
  | Status_ExecutionFailed
  | Status_ExecutionSucceeded
  deriving (Int -> Status -> FilePath -> FilePath
[Status] -> FilePath -> FilePath
Status -> FilePath
(Int -> Status -> FilePath -> FilePath)
-> (Status -> FilePath)
-> ([Status] -> FilePath -> FilePath)
-> Show Status
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Status] -> FilePath -> FilePath
$cshowList :: [Status] -> FilePath -> FilePath
show :: Status -> FilePath
$cshow :: Status -> FilePath
showsPrec :: Int -> Status -> FilePath -> FilePath
$cshowsPrec :: Int -> Status -> FilePath -> FilePath
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)

-- | Collect all the GHCi module output (i.e., errors, warnings, etc) and optionally clear
-- every time GHCi reloads
moduleOutput
  :: (Reflex t, MonadFix m, MonadHold t m)
  => Behavior t Bool
  -- ^ Whether to clear the output on reload
  -> Ghci t
  -> m (Dynamic t ByteString)
moduleOutput :: Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
moduleOutput clear :: Behavior t Bool
clear g :: 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]

-- | Collect all the GHCi expression output (i.e., the output of the called function) and optionally clear
-- every time GHCi reloads
execOutput
  :: (Reflex t, MonadFix m, MonadHold t m)
  => Behavior t Bool
  -- ^ Whether to clear the output on reload
  -> Ghci t
  -> m (Dynamic t ByteString)
execOutput :: Behavior t Bool -> Ghci t -> m (Dynamic t ByteString)
execOutput clear :: Behavior t Bool
clear g :: 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]

-- | Collect output, appending new output to the end of the accumulator
collectOutput
  :: (Reflex t, MonadFix m, MonadHold t m)
  => Event t ()
  -- ^ Clear output
  -> Event t ByteString
  -- ^ Output to add
  -> m (Dynamic t ByteString)
collectOutput :: Event t () -> Event t ByteString -> m (Dynamic t ByteString)
collectOutput clear :: Event t ()
clear out :: 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
($) "" (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)
-> Event t () -> Event t (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
clear
  ]

-- | Describe the current status of GHCi in a human-readable way
statusMessage :: IsString a => Status -> a
statusMessage :: Status -> a
statusMessage = \case
  Status_Initializing -> "Initializing..."
  Status_Loading -> "Loading Modules..."
  Status_LoadFailed -> "Failed to Load Modules!"
  Status_LoadSucceeded -> "Successfully Loaded Modules!"
  Status_Executing -> "Executing Command..."
  Status_ExecutionFailed -> "Command Failed!"
  Status_ExecutionSucceeded -> "Command Succeeded!"