{-# 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 = (<>) "<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 cmd mexpr reloadReq = do
let msgInit = msg "performing setup..."
msgExprStarted = msg "evaluating expression..."
msgExprFinished = msg "expression evaluation ended."
putMsgLn :: ByteString -> ByteString
putMsgLn m = "Prelude.putStrLn \"" <> m <> "\"\n"
rec proc <- createProcess cmd $ ProcessConfig
{ _processConfig_stdin = SendPipe_Message . (<> "\n") <$> leftmost
[ reload
, fforMaybe (updated status) $ \case
Status_LoadSucceeded -> ffor mexpr $ \expr ->
C8.intercalate "\n"
[ putMsgLn msgExprStarted
, putMsgLn expr
, expr
, putMsgLn msgExprFinished
]
_ -> Nothing
, let f old new = if old == Status_Initializing && new == Status_Loading
then Just $ C8.intercalate "\n"
[ putMsgLn msgInit
, ":set prompt ..."
, ":set -fno-break-on-exception"
, ":set -fno-break-on-error"
, ":set prompt \"\""
, putMsgLn ""
, ":set prompt " <> prompt
, ":r"
]
else Nothing
in attachWithMaybe f (current status) (updated status)
]
, _processConfig_signal = sigINT <$ requestInterrupt
}
let reload = leftmost
[ ":r" <$ reloadReq
]
output <- collectOutput (() <$ reload) $ _process_stdout proc
errors <- collectOutput (() <$ reload) $ _process_stderr proc
let interruptible s = s `elem` [Status_Loading, Status_Executing]
requestInterrupt = gate (interruptible <$> current status) (() <$ reloadReq)
let okModulesLoaded = "Ok.*module.*loaded." :: ByteString
failedNoModulesLoaded = "Failed,.*module.*loaded." :: ByteString
exceptionMessage = "\\*\\*\\* Exception:.*" :: ByteString
interactiveErrorMessage = "<interactive>:.*:.*:.error:.*" :: ByteString
ghciVersionMessage = "GHCi, version.*: https?://www.haskell.org/ghc/" :: ByteString
status :: Dynamic t Status <- holdUniqDyn <=< foldDyn ($) Status_Initializing $ leftmost
[ fforMaybe (updated errors) $ \err -> if err Regex.=~ exceptionMessage || err Regex.=~ interactiveErrorMessage
then Just $ const Status_ExecutionFailed
else Nothing
, const Status_Loading <$ reload
, ffor (updated output) $ \out -> case reverse (C8.lines out) of
lastLine:expectedMessage:_
| lastLine == prompt && expectedMessage Regex.=~ okModulesLoaded -> const Status_LoadSucceeded
| lastLine == prompt && expectedMessage Regex.=~ failedNoModulesLoaded -> const Status_LoadFailed
| lastLine == prompt && expectedMessage == msgExprStarted -> const Status_Executing
| lastLine Regex.=~ (prompt :: String) && expectedMessage Regex.=~ msgExprFinished -> const Status_ExecutionSucceeded
| lastLine Regex.=~ ghciVersionMessage -> const Status_Loading
| otherwise -> \case
Status_LoadSucceeded -> case mexpr of
Nothing -> Status_LoadSucceeded
Just _ -> Status_Executing
s -> s
lastLine:_
| lastLine Regex.=~ ghciVersionMessage -> const Status_Loading
_ -> id
]
execStream <- hold False $ leftmost
[ False <$ reload
, fforMaybe (updated status) $ \case
Status_LoadSucceeded -> Just True
Status_LoadFailed -> Just False
Status_Executing -> Just True
_ -> Nothing
]
return $ Ghci
{ _ghci_moduleOut = gate (not <$> execStream) $ _process_stdout proc
, _ghci_moduleErr = gate (not <$> execStream) $ _process_stderr proc
, _ghci_execOut = gate execStream $ _process_stdout proc
, _ghci_execErr = gate execStream $ _process_stderr proc
, _ghci_reload = () <$ reload
, _ghci_status = status
, _ghci_process = proc
}
where
prompt :: IsString a => a
prompt = "<| 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 p mexec = do
dir <- liftIO getCurrentDirectory
pb <- getPostBuild
let fsConfig = noDebounce $ FS.defaultConfig
{ FS.confUsePolling = Sys.os == "darwin"
, FS.confPollInterval = 250000
}
fsEvents <- watchDirectoryTree fsConfig (dir <$ pb) $ \e ->
takeExtension (FS.eventPath e) `elem` [".hs", ".lhs"]
batchedFsEvents <- batchOccurrences 0.1 fsEvents
ghci p mexec $ () <$ batchedFsEvents
where
noDebounce :: FS.WatchConfig -> FS.WatchConfig
noDebounce cfg = cfg { FS.confDebounce = FS.NoDebounce }
data Ghci t = Ghci
{ _ghci_moduleOut :: Event t ByteString
, _ghci_moduleErr :: Event t ByteString
, _ghci_execOut :: Event t ByteString
, _ghci_execErr :: Event t ByteString
, _ghci_reload :: Event t ()
, _ghci_status :: Dynamic t Status
, _ghci_process :: Process t ByteString ByteString
}
data Status
= Status_Initializing
| Status_Loading
| Status_LoadFailed
| Status_LoadSucceeded
| Status_Executing
| Status_ExecutionFailed
| Status_ExecutionSucceeded
deriving (Show, Read, Eq, Ord)
moduleOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Behavior t Bool
-> Ghci t
-> m (Dynamic t ByteString)
moduleOutput clear g = collectOutput
(gate clear $ () <$ _ghci_reload g) $
leftmost [_ghci_moduleOut g, _ghci_moduleErr g]
execOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Behavior t Bool
-> Ghci t
-> m (Dynamic t ByteString)
execOutput clear g = collectOutput
(gate clear $ () <$ _ghci_reload g) $
leftmost [_ghci_execOut g, _ghci_execErr g]
collectOutput
:: (Reflex t, MonadFix m, MonadHold t m)
=> Event t ()
-> Event t ByteString
-> m (Dynamic t ByteString)
collectOutput clear out = foldDyn ($) "" $ leftmost
[ flip mappend <$> out
, const "" <$ clear
]
statusMessage :: IsString a => 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!"