{-|
 - 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 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>: "

-- | 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 CreateProcess
cmd Maybe ByteString
mexpr Event t ()
reloadReq = do
  -- Run the process and feed it some input:
  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
            -- 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
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
            -- On first load, set the prompt
            , 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
        }

      -- 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
            [ ByteString
":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 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 = ByteString
"Ok.*module.*loaded." :: ByteString
          failedNoModulesLoaded :: ByteString
failedNoModulesLoaded = ByteString
"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 = ByteString
"\\*\\*\\* Exception:.*" :: ByteString
          interactiveErrorMessage :: ByteString
interactiveErrorMessage = ByteString
"<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 = ByteString
"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
$ \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
        ]

  -- 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
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
      ]

  -- 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 = a
"<| 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 CreateProcess
p Maybe ByteString
mexec = do
  -- Get the current directory so we can observe changes in it
  String
dir <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
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.

  -- On macOS, use the polling backend due to https://github.com/luite/hfsevents/issues/13
  -- TODO check if this is an issue with nixpkgs
  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"]

  -- 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 NominalDiffTime
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 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 -> 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)

-- | 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 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]

-- | 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 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]

-- | 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 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
  ]

-- | Describe the current status of GHCi in a human-readable way
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!"