{-|
 - Module: Reflex.Process.GHCi
 - Description: Run GHCi processes in a reflex application
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Reflex.Process.GHCi
  ( ghci
  , ghciWatch
  , module X
  , hasErrors
  ) where

import Reflex
import Reflex.FSNotify (watchDirectoryTree)
import Reflex.Process (Process(..))

import Control.Monad
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import qualified Data.Map as Map
import System.Directory (getCurrentDirectory)
import qualified System.FSNotify as FS
import System.FilePath.Posix (takeExtension)
import qualified System.Info as Sys
import qualified System.Posix.Signals as Signals
import qualified System.Process as P
import qualified Text.Regex.TDFA as Regex ((=~))

import Reflex.Process.Repl as X

-- | Runs a GHCi process and reloads it whenever the provided event fires
ghci
  :: ( Adjustable t m
     , MonadFix m
     , MonadHold t m
     , MonadIO (Performable m)
     , MonadIO m
     , NotReady t m
     , PerformEvent t m
     , PostBuild t m
     , TriggerEvent t m
     )
  => P.CreateProcess -- ^ How to run GHCi
  -> Event t [Command] -- ^ Send an expression to evaluate
  -> Event t () -- ^ Reload
  -> Event t () -- ^ Shutdown
  -> m (Repl t)
ghci :: CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
ghci CreateProcess
runGhci Event t [Command]
expr Event t ()
reload Event t ()
shutdown = do
  Handler
_ <- IO Handler -> m Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigINT (IO () -> Handler
Signals.Catch (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Maybe SignalSet
forall a. Maybe a
Nothing
  Event t ()
pb <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  rec
    r :: Repl t
r@(Repl Process t ByteString ByteString
proc Event t (Map Int Cmd)
_finished Dynamic t (Int, Maybe Cmd)
started Event t ExitCode
exit) <- CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
forall t (m :: * -> *).
(Adjustable t m, MonadFix m, MonadHold t m,
 MonadIO (Performable m), MonadIO m, NotReady t m, PerformEvent t m,
 PostBuild t m, TriggerEvent t m) =>
CreateProcess
-> Event t [Command] -> (Int -> ByteString -> Bool) -> m (Repl t)
repl CreateProcess
runGhci Event t [Command]
inputs Int -> ByteString -> Bool
forall a. Show a => a -> ByteString -> Bool
isPrompt
    let inputs :: Event t [Command]
inputs = ([Command] -> [Command] -> [Command])
-> [Event t [Command]] -> Event t [Command]
forall k (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
(<>)
          [ [ByteString] -> [Command]
commands [ByteString]
setupCommands [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb
          , ByteString -> [Command]
command ByteString
":r" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
interrupted
          , ByteString -> [Command]
command ByteString
":r" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
reload'
          , ByteString -> [Command]
command ByteString
":q" [Command] -> Event t () -> Event t [Command]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
shutdown
          , Event t [Command]
expr
          ]
    let interruptible :: Dynamic t Bool
interruptible = Dynamic t (Int, Maybe Cmd)
-> ((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t (Int, Maybe Cmd)
started (((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool)
-> ((Int, Maybe Cmd) -> Bool) -> Dynamic t Bool
forall a b. (a -> b) -> a -> b
$ \case
          (Int
_, Maybe Cmd
Nothing) -> Bool
False
          (Int, Maybe Cmd)
_ -> Bool
True
    -- Don't allow reloads too close together. Sometimes a single change that
    -- results in a reload might actually cause multiple reload events (e.g.,
    -- an editor writing a file by deleting and writing it, resulting in two
    -- filesystem events)
    Event t ()
reloadThrottled <- NominalDiffTime -> Event t () -> m (Event t ())
forall (m :: * -> *) t a.
(MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m,
 MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
throttle NominalDiffTime
0.1 Event t ()
reload
    let reload' :: Event t ()
reload' = Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate (Bool -> Bool
not (Bool -> Bool) -> Behavior t Bool -> Behavior t Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
interruptible) Event t ()
reloadThrottled
    Event t ()
interrupted <- Event t (Performable m ()) -> m (Event t ())
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m ()) -> m (Event t ()))
-> Event t (Performable m ()) -> m (Event t ())
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (Behavior t Bool -> Event t () -> Event t ()
forall k (t :: k) a.
Reflex t =>
Behavior t Bool -> Event t a -> Event t a
gate (Dynamic t Bool -> Behavior t Bool
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Bool
interruptible) Event t ()
reloadThrottled) ((() -> Performable m ()) -> Event t (Performable m ()))
-> (() -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
      IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
P.interruptProcessGroupOf (ProcessHandle -> IO ()) -> ProcessHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ Process t ByteString ByteString -> ProcessHandle
forall t o e. Process t o e -> ProcessHandle
_process_handle Process t ByteString ByteString
proc
    -- If we can't shut down cleanly within 2 seconds, kill it
    Event t ()
forceShutdown <- NominalDiffTime -> Event t () -> m (Event t ())
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
2 Event t ()
shutdown
    Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ()
-> (() -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ()
forceShutdown ((() -> Performable m ()) -> Event t (Performable m ()))
-> (() -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ do
      let h :: ProcessHandle
h = Process t ByteString ByteString -> ProcessHandle
forall t o e. Process t o e -> ProcessHandle
_process_handle Process t ByteString ByteString
proc
      ProcessHandle -> IO ()
P.interruptProcessGroupOf ProcessHandle
h
      ProcessHandle -> IO ()
P.terminateProcess ProcessHandle
h
    -- Reinstall the default signal handler after the repl process exits
    Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ExitCode
-> (ExitCode -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ExitCode
exit ((ExitCode -> Performable m ()) -> Event t (Performable m ()))
-> (ExitCode -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \ExitCode
_ -> IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$
      IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigINT Handler
Signals.Default Maybe SignalSet
forall a. Maybe a
Nothing
  Repl t -> m (Repl t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Repl t
r
  where
    promptPostfix :: ByteString
    promptPostfix :: ByteString
promptPostfix = ByteString
"_reflex_ghci_prompt>"
    isPrompt :: a -> ByteString -> Bool
isPrompt a
cur ByteString
line = (String -> ByteString
C8.pack (a -> String
forall a. Show a => a -> String
show a
cur) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
line
    setupCommands :: [ByteString]
setupCommands =
      [ ByteString
":set prompt-function \\_ x -> let s = \"\\n\" <> show x <> \"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
promptPostfix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\\n\" in System.IO.hPutStr System.IO.stderr s >> pure s"
      , ByteString
":set -fno-break-on-exception"
      , ByteString
":set -fno-break-on-error"
      , ByteString
":set -v1"
      , ByteString
":set -fno-hide-source-paths"
      , ByteString
":set -ferror-spans"
      , ByteString
":set -fdiagnostics-color=never" -- TODO handle ansi escape codes in output
      , ByteString
":r" -- This is here because we might hit errors at load time, before we've had a chance to set up the prompt. This will re-print those errors.
      ]

-- | Detect errors reported in stdout or stderr
hasErrors :: Cmd -> Bool
hasErrors :: Cmd -> Bool
hasErrors (Cmd Command
_ Lines
o Lines
e) =
  let errs :: source1 -> Bool
errs source1
l =
        source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
exceptionMessage Bool -> Bool -> Bool
||
        source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
interactiveErrorMessage Bool -> Bool -> Bool
||
        source1
l source1 -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
moduleLoadError
      errOnStderr :: Bool
errOnStderr = (ByteString -> Bool) -> Seq ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ByteString -> Bool
forall source1. RegexLike Regex source1 => source1 -> Bool
errs (Seq ByteString -> Bool) -> Seq ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Lines -> Seq ByteString
_lines_terminated Lines
e
      errOnStdout :: Bool
errOnStdout = (ByteString -> Bool) -> Seq ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
Regex.=~ ByteString
failedModulesLoaded) (Seq ByteString -> Bool) -> Seq ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Lines -> Seq ByteString
_lines_terminated Lines
o
  in Bool
errOnStderr Bool -> Bool -> Bool
|| Bool
errOnStdout

-- | 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
     , Adjustable t m
     , NotReady t m
     )
  => P.CreateProcess
  -> Maybe Command
  -> Event t ()
  -> Event t ()
  -> m (Repl t)
ghciWatch :: CreateProcess
-> Maybe Command -> Event t () -> Event t () -> m (Repl t)
ghciWatch CreateProcess
p Maybe Command
mexpr Event t ()
reload Event t ()
shutdown = do
  -- 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
FS.defaultConfig
        { confWatchMode :: WatchMode
FS.confWatchMode =
            if String
Sys.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"darwin"
              then Int -> WatchMode
FS.WatchModePoll Int
200000
              else WatchMode
FS.WatchModeOS
        }
  Event t FSEvent
fsEvents <- WatchConfig
-> Event t String -> ActionPredicate -> m (Event t FSEvent)
forall t (m :: * -> *).
(Reflex t, TriggerEvent t m, PerformEvent t m,
 MonadIO (Performable m)) =>
WatchConfig
-> Event t String -> ActionPredicate -> m (Event t FSEvent)
watchDirectoryTree WatchConfig
fsConfig (String
dir String -> Event t () -> Event t String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
pb) (ActionPredicate -> m (Event t FSEvent))
-> ActionPredicate -> m (Event t FSEvent)
forall a b. (a -> b) -> a -> b
$ \FSEvent
e ->
    String -> String
takeExtension (FSEvent -> String
FS.eventPath FSEvent
e) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]

  -- 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.05 Event t FSEvent
fsEvents

  -- Call GHCi, request a reload every time the files we're watching change.
  let reloadEvents :: Event t ()
reloadEvents = ((() () -> Event t (Seq FSEvent) -> Event t ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t (Seq FSEvent)
batchedFsEvents) Event t () -> Event t () -> Event t ()
forall a. Semigroup a => a -> a -> a
<> Event t ()
reload)

  rec Repl t
g <- CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
forall t (m :: * -> *).
(Adjustable t m, MonadFix m, MonadHold t m,
 MonadIO (Performable m), MonadIO m, NotReady t m, PerformEvent t m,
 PostBuild t m, TriggerEvent t m) =>
CreateProcess
-> Event t [Command] -> Event t () -> Event t () -> m (Repl t)
ghci CreateProcess
p Event t [Command]
sendExpr Event t ()
reloadEvents Event t ()
shutdown
      Event t [Command]
sendExpr <- NominalDiffTime -> Event t [Command] -> m (Event t [Command])
forall t (m :: * -> *) a.
(PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) =>
NominalDiffTime -> Event t a -> m (Event t a)
delay NominalDiffTime
0.1 (Event t [Command] -> m (Event t [Command]))
-> Event t [Command] -> m (Event t [Command])
forall a b. (a -> b) -> a -> b
$ Event t (Map Int Cmd)
-> (Map Int Cmd -> Maybe [Command]) -> Event t [Command]
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe (Repl t -> Event t (Map Int Cmd)
forall t. Repl t -> Event t (Map Int Cmd)
_repl_finished Repl t
g) ((Map Int Cmd -> Maybe [Command]) -> Event t [Command])
-> (Map Int Cmd -> Maybe [Command]) -> Event t [Command]
forall a b. (a -> b) -> a -> b
$ \Map Int Cmd
finished -> case [Cmd] -> [Cmd]
forall a. [a] -> [a]
reverse (Map Int Cmd -> [Cmd]
forall k a. Map k a -> [a]
Map.elems Map Int Cmd
finished) of
            c :: Cmd
c@(Cmd Command
cmd Lines
_ Lines
_):[Cmd]
_ -> if Command -> ByteString
displayCommand Command
cmd ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
":r" Bool -> Bool -> Bool
&& Bool -> Bool
not (Cmd -> Bool
hasErrors Cmd
c)
              then case Maybe Command
mexpr of
                Maybe Command
Nothing -> Maybe [Command]
forall a. Maybe a
Nothing
                Just Command
expr -> [Command] -> Maybe [Command]
forall a. a -> Maybe a
Just [Command
expr]
              else Maybe [Command]
forall a. Maybe a
Nothing
            [Cmd]
_ -> Maybe [Command]
forall a. Maybe a
Nothing
  Repl t -> m (Repl t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Repl t
g

failedModulesLoaded :: ByteString
failedModulesLoaded :: ByteString
failedModulesLoaded = ByteString
"Failed,.*module.*loaded." :: ByteString

-- 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
exceptionMessage = ByteString
"\\*\\*\\* Exception:.*" :: ByteString

interactiveErrorMessage :: ByteString
interactiveErrorMessage :: ByteString
interactiveErrorMessage = ByteString
"<interactive>:.*:.*:.error:.*" :: ByteString

moduleLoadError :: ByteString
moduleLoadError :: ByteString
moduleLoadError = ByteString
"^.+\\.(l)?hs:[0-9]+:[0-9]+: error:$"