reflex-ghci 0.1.5.4 → 0.2.0.0
raw patch · 15 files changed
+692/−625 lines, 15 filesdep +containersdep +semialigndep +thesedep ~basedep ~bytestringdep ~filepath
Dependencies added: containers, semialign, these
Dependency ranges changed: base, bytestring, filepath, fsnotify, optparse-applicative, reflex, reflex-fsnotify, reflex-process, reflex-vty, text, unix, vty
Files
- ChangeLog.md +6/−0
- README.md +1/−1
- reflex-ghci.cabal +21/−14
- src-bin/ghci.hs +1/−8
- src/Reflex/Process/GHCi.hs +113/−220
- src/Reflex/Process/Repl.hs +404/−0
- src/Reflex/Vty/GHCi.hs +50/−175
- tests/lib-pkg-name/Setup.hs +2/−0
- tests/lib-pkg-name/src/MyLib.hs +8/−0
- tests/lib-pkg-name/src/MyLib/One.hs +4/−0
- tests/lib-pkg-name/src/MyLib/Three.hs +4/−0
- tests/lib-pkg-name/src/MyLib/Two.hs +4/−0
- tests/lib-pkg-name/test-pkg2.cabal +28/−0
- tests/lib-pkg/src/MyLib.hs +1/−1
- tests/test.hs +45/−206
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for reflex-ghci +## 0.2.0.0++* Support ghc 9.6 and reflex-vty 0.4+* *Breaking change*: Expose a new interface that more robustly represents the state of the child ghci process.+* Show the most recently run commands and allow user to select from them to see their output+ ## 0.1.5.4 * Support ghc 8.10 and reflex-vty 0.3
README.md view
@@ -1,6 +1,6 @@ # reflex-ghci -[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-ghci) [](https://matrix.hackage.haskell.org/#/package/reflex-ghci) [](https://travis-ci.org/reflex-frp/reflex-ghci) [](https://github.com/reflex-frp/reflex-ghci/blob/master/LICENSE)+[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-ghci) [](https://github.com/reflex-frp/reflex-ghci/blob/master/LICENSE) Run GHCi from within a [Reflex FRP](https://reflex-frp.org) application and interact with it using a functional reactive interface.
reflex-ghci.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: reflex-ghci-version: 0.1.5.4+version: 0.2.0.0 synopsis: A GHCi widget library for use in reflex applications description: Run GHCi from within a Reflex FRP (<https://reflex-frp.org>) application and interact with it using a functional reactive interface.@@ -18,27 +18,31 @@ README.md tests/**/*.hs tests/**/*.cabal-tested-with: GHC ==8.6.5 || ==8.8.4+tested-with: GHC ==8.6.5 || ==8.8.4 || ==9.6.1 library exposed-modules: Reflex.Process.GHCi+ Reflex.Process.Repl Reflex.Vty.GHCi build-depends:- base >= 4.12 && < 4.15- , bytestring >= 0.10 && < 0.11+ base >= 4.12 && < 4.19+ , bytestring >= 0.10 && < 0.12+ , containers >= 0.6 && < 0.7 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5- , fsnotify >= 0.3 && < 0.4+ , fsnotify >= 0.4 && < 0.5 , process >= 1.6 && < 1.7- , reflex >= 0.7.1.0 && < 0.9- , reflex-fsnotify >= 0.2 && < 0.3- , reflex-process >= 0.3 && < 0.4+ , reflex >= 0.7.1.0 && < 1+ , reflex-fsnotify >= 0.3 && < 0.4+ , reflex-process >= 0.3.2 && < 0.4 , regex-tdfa >= 1.2.3 && < 1.4- , reflex-vty >= 0.3 && < 0.4- , text >= 1.2 && < 1.3- , unix >= 2.7 && < 2.8- , vty >=5.21 && <5.37+ , reflex-vty >= 0.3 && < 0.5+ , semialign > 1 && < 2+ , text >= 1.2 && < 2.1+ , these > 1 && < 2+ , unix >= 2.7 && < 2.9+ , vty >=5.21 && <5.39 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -48,9 +52,9 @@ main-is: ghci.hs build-depends: base- , optparse-applicative >= 0.14.0 && < 0.17+ , optparse-applicative >= 0.14.0 && < 0.19 , process- , reflex >= 0.7.1.0+ , reflex , reflex-ghci , reflex-vty , reflex-process@@ -67,7 +71,10 @@ hs-source-dirs: tests build-depends: base+ , bytestring+ , containers , directory+ , filepath , process , reflex , reflex-ghci
src-bin/ghci.hs view
@@ -44,14 +44,7 @@ showVersion version ] GhciArg { _ghciArg_replCommand = cmd, _ghciArg_execCommand = expr } <- execParser opts- mainWidget $ initManager_ $ do- exit <- keyCombo (V.KChar 'c', [V.MCtrl])- g <- ghciWatch (shell cmd) $ T.encodeUtf8 . T.pack <$> expr- case expr of- Nothing -> ghciModuleStatus g- Just _ -> ghciPanes g- readyToExit <- performEvent $ ffor exit $ \_ -> liftIO $ terminateProcess $ _process_handle $ _ghci_process g- return $ () <$ readyToExit+ run cmd expr -- Some rudimentary test expressions -- Run these to test different scenarios like so:
src/Reflex/Process/GHCi.hs view
@@ -4,172 +4,113 @@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} module Reflex.Process.GHCi ( ghci , ghciWatch- , Ghci(..)- , Status(..)- , moduleOutput- , execOutput- , collectOutput- , statusMessage+ , module X+ , hasErrors ) where import Reflex import Reflex.FSNotify (watchDirectoryTree)-import Reflex.Process (ProcessConfig(..), Process(..), SendPipe(..), createProcess)+import Reflex.Process (Process(..)) -import Control.Monad ((<=<))+import Control.Monad import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8-import Data.String (IsString)+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 System.Posix.Signals (sigINT)+import qualified System.Posix.Signals as Signals import qualified System.Process as P import qualified Text.Regex.TDFA as Regex ((=~)) -msg :: (IsString a, Semigroup a) => a -> a-msg = (<>) "<reflex-ghci>: "+import Reflex.Process.Repl as X -- | 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+ :: ( 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- -- ^ 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 cmd mexpr reloadReq = do- -- Run the process and feed it some input:- 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- -- Execute some expression if GHCi is ready to receive it- , fforMaybe (updated status) $ \case- Status_LoadSucceeded -> ffor mexpr $ \expr ->- C8.intercalate "\n"- [ putMsgLn msgExprStarted- , putMsgLn expr- , expr- , putMsgLn msgExprFinished- ]- _ -> Nothing- -- On first load, set the prompt- , 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- }-- -- Reload- let reload = leftmost- [ ":r" <$ reloadReq- ]-- -- Capture and accumulate stdout and stderr between reloads.- -- We'll inspect these values to determine GHCi's state- output <- collectOutput (() <$ reload) $ _process_stdout proc- errors <- collectOutput (() <$ reload) $ _process_stderr proc-- -- Only interrupt when there's a file change and we're ready and not in an idle state- let interruptible s = s `elem` [Status_Loading, Status_Executing]- requestInterrupt = gate (interruptible <$> current status) (() <$ reloadReq)-- -- Define some Regex patterns to use to determine GHCi's state based on output- let okModulesLoaded = "Ok.*module.*loaded." :: 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 = "\\*\\*\\* Exception:.*" :: 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 = "GHCi, version.*: https?://www.haskell.org/ghc/" :: ByteString-- -- Inspect the output and determine what state GHCi is in- 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- ]-- -- Determine when to switch output stream from GHCi module output to execution output- execStream <- hold False $ leftmost- [ False <$ reload- , fforMaybe (updated status) $ \case- Status_LoadSucceeded -> Just True- Status_LoadFailed -> Just False- Status_Executing -> Just True- _ -> Nothing+ => P.CreateProcess -- ^ How to run GHCi+ -> Event t [Command] -- ^ Send an expression to evaluate+ -> Event t () -- ^ Reload+ -> Event t () -- ^ Shutdown+ -> m (Repl t)+ghci runGhci expr reload shutdown = do+ _ <- liftIO $ Signals.installHandler Signals.sigINT (Signals.Catch (return ())) Nothing+ pb <- getPostBuild+ rec+ r@(Repl proc _finished started exit) <- repl runGhci inputs isPrompt+ let inputs = mergeWith (<>)+ [ commands setupCommands <$ pb+ , command ":r" <$ interrupted+ , command ":r" <$ reload'+ , command ":q" <$ shutdown+ , expr+ ]+ let interruptible = ffor started $ \case+ (_, Nothing) -> False+ _ -> 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)+ reloadThrottled <- throttle 0.1 reload+ let reload' = gate (not <$> current interruptible) reloadThrottled+ interrupted <- performEvent $ ffor (gate (current interruptible) reloadThrottled) $ \_ -> do+ liftIO $ P.interruptProcessGroupOf $ _process_handle proc+ -- If we can't shut down cleanly within 2 seconds, kill it+ forceShutdown <- delay 2 shutdown+ performEvent_ $ ffor forceShutdown $ \_ -> liftIO $ do+ let h = _process_handle proc+ P.interruptProcessGroupOf h+ P.terminateProcess h+ -- Reinstall the default signal handler after the repl process exits+ performEvent_ $ ffor exit $ \_ -> liftIO $+ void $ Signals.installHandler Signals.sigINT Signals.Default Nothing+ pure r+ where+ promptPostfix :: ByteString+ promptPostfix = "_reflex_ghci_prompt>"+ isPrompt cur line = (C8.pack (show cur) <> promptPostfix) == line+ setupCommands =+ [ ":set prompt-function \\_ x -> let s = \"\\n\" <> show x <> \"" <> promptPostfix <> "\\n\" in System.IO.hPutStr System.IO.stderr s >> pure s"+ , ":set -fno-break-on-exception"+ , ":set -fno-break-on-error"+ , ":set -v1"+ , ":set -fno-hide-source-paths"+ , ":set -ferror-spans"+ , ":set -fdiagnostics-color=never" -- TODO handle ansi escape codes in output+ , ":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. ] - -- 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- 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 |>"+-- | Detect errors reported in stdout or stderr+hasErrors :: Cmd -> Bool+hasErrors (Cmd _ o e) =+ let errs l =+ l Regex.=~ exceptionMessage ||+ l Regex.=~ interactiveErrorMessage ||+ l Regex.=~ moduleLoadError+ errOnStderr = any errs $ _lines_terminated e+ errOnStdout = any (Regex.=~ failedModulesLoaded) $ _lines_terminated o+ in errOnStderr || errOnStdout -- | Run a GHCi process that watches for changes to Haskell source files in the -- current directory and reloads if they are modified@@ -181,11 +122,15 @@ , MonadIO m , MonadFix m , MonadHold t m+ , Adjustable t m+ , NotReady t m ) => P.CreateProcess- -> Maybe ByteString- -> m (Ghci t)-ghciWatch p mexec = do+ -> Maybe Command+ -> Event t ()+ -> Event t ()+ -> m (Repl t)+ghciWatch p mexpr reload shutdown = do -- Get the current directory so we can observe changes in it dir <- liftIO getCurrentDirectory @@ -199,9 +144,11 @@ -- 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 = noDebounce $ FS.defaultConfig- { FS.confUsePolling = Sys.os == "darwin"- , FS.confPollInterval = 250000+ let fsConfig = FS.defaultConfig+ { FS.confWatchMode =+ if Sys.os == "darwin"+ then FS.WatchModePoll 200000+ else FS.WatchModeOS } fsEvents <- watchDirectoryTree fsConfig (dir <$ pb) $ \e -> takeExtension (FS.eventPath e) `elem` [".hs", ".lhs"]@@ -209,86 +156,32 @@ -- 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- batchedFsEvents <- batchOccurrences 0.1 fsEvents-- -- Call GHCi and request a reload every time the files we're watching change- ghci p mexec $ () <$ batchedFsEvents- where- noDebounce :: FS.WatchConfig -> FS.WatchConfig- noDebounce cfg = cfg { FS.confDebounce = FS.NoDebounce }+ batchedFsEvents <- batchOccurrences 0.05 fsEvents --- | The output of the GHCi process-data Ghci t = Ghci- { _ghci_moduleOut :: Event t ByteString- -- ^ stdout output produced when loading modules- , _ghci_moduleErr :: Event t ByteString- -- ^ stderr output produced when loading modules- , _ghci_execOut :: Event t ByteString- -- ^ stdout output produced while evaluating an expression- , _ghci_execErr :: Event t ByteString- -- ^ stderr output produced while evaluating an expression- , _ghci_reload :: Event t ()- -- ^ Event that fires when GHCi is reloading- , _ghci_status :: Dynamic t Status- -- ^ The current status of the GHCi process- , _ghci_process :: Process t ByteString ByteString- }+ -- Call GHCi, request a reload every time the files we're watching change.+ let reloadEvents = ((() <$ batchedFsEvents) <> reload) --- | The state of the GHCi process-data Status- = Status_Initializing- | Status_Loading- | Status_LoadFailed- | Status_LoadSucceeded- | Status_Executing- | Status_ExecutionFailed- | Status_ExecutionSucceeded- deriving (Show, Read, Eq, Ord)+ rec g <- ghci p sendExpr reloadEvents shutdown+ sendExpr <- delay 0.1 $ fforMaybe (_repl_finished g) $ \finished -> case reverse (Map.elems finished) of+ c@(Cmd cmd _ _):_ -> if displayCommand cmd == ":r" && not (hasErrors c)+ then case mexpr of+ Nothing -> Nothing+ Just expr -> Just [expr]+ else Nothing+ _ -> Nothing+ pure g --- | 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 clear g = collectOutput- (gate clear $ () <$ _ghci_reload g) $- leftmost [_ghci_moduleOut g, _ghci_moduleErr g]+failedModulesLoaded :: ByteString+failedModulesLoaded = "Failed,.*module.*loaded." :: ByteString --- | 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 clear g = collectOutput- (gate clear $ () <$ _ghci_reload g) $- leftmost [_ghci_execOut g, _ghci_execErr g]+-- 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 --- | 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 clear out = foldDyn ($) "" $ leftmost- [ flip mappend <$> out- , const "" <$ clear- ]+interactiveErrorMessage :: ByteString+interactiveErrorMessage = "<interactive>:.*:.*:.error:.*" :: ByteString --- | Describe the current status of GHCi in a human-readable way-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!"+moduleLoadError :: ByteString+moduleLoadError = "^.+\\.(l)?hs:[0-9]+:[0-9]+: error:$"
+ src/Reflex/Process/Repl.hs view
@@ -0,0 +1,404 @@+{-|+ - Module: Reflex.Process.Repl+ - Description: Run repl-like processes in a reflex application.+-}++{-# Language BangPatterns #-}+{-# Language FlexibleContexts #-}+{-# Language FlexibleInstances #-}+{-# Language LambdaCase #-}+{-# Language MultiParamTypeClasses #-}+{-# Language MultiWayIf #-}+{-# Language OverloadedStrings #-}+{-# Language RecursiveDo #-}+{-# Language ScopedTypeVariables #-}+{-# Language StandaloneDeriving #-}+{-# Language TupleSections #-}+module Reflex.Process.Repl+ ( Repl(..)+ , Cmd(..)+ , Accum(..)+ , accumHandle+ , accumHandles+ , flushAccum+ , repl+ , Lines(..)+ , emptyLines+ , addLines+ , linesFromBS+ , unLines+ , lastWholeLine+ , splitLinesOn+ , Command+ , unsafeCommand+ , command+ , commands+ , displayCommand+ , sendCommands+ , testRepl+ , mkTestCommands+ , assertStdoutEq+ , assertStderrEq+ , assertStderr+ , assertStdout+ , assertHandleEq+ , assertHandle+ , assertCmd+ ) where++import Control.Concurrent (forkIO)+import Control.Monad+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Align (align)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.Foldable (toList)+import Data.IORef+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import Data.These (These(..))+import Reflex+import Reflex.Host.Headless+import Reflex.Process+import System.Exit (ExitCode)+import qualified System.Posix.Signals as Signals+import qualified System.Process as P++-- * REPL++-- | Output of a 'repl' session+data Repl t = Repl+ { _repl_process :: Process t ByteString ByteString+ -- ^ The underlying repl process, which can be used to access the process handle, the raw output, and so on.+ , _repl_finished :: Event t (Map Int Cmd)+ -- ^ An event of commands that the repl has finished executing and their+ -- associated output. The 'Int' here represents the order in which commands+ -- were submitted to the repl.+ , _repl_started :: Dynamic t (Int, Maybe Cmd)+ -- ^ A dynamic of the currently running command, if any, and its output. The+ -- 'Int' here represents the ordering of this command relative to the ones in+ -- '_repl_finished'.+ , _repl_exited :: Event t ExitCode+ -- ^ An event that fires when the repl exits+ }++-- | An individual command submitted to the repl, and its output+data Cmd = Cmd+ { _cmd_stdin :: Command+ , _cmd_stdout :: Lines+ , _cmd_stderr :: Lines+ }+ deriving (Eq, Ord, Show)++-- | An accumulator used to track and combine the repl's output streams +data Accum = Accum+ { _accum_stdout :: (Map Int Lines, Int, Lines)+ , _accum_stderr :: (Map Int Lines, Int, Lines)+ }++-- | Accumulate a handle, grouping its output by prompts+accumHandle+ :: (Int -> ByteString -> Bool)+ -> ByteString+ -> (Map Int Lines, Int, Lines)+ -> (Map Int Lines, Int, Lines)+accumHandle isPrompt new (done, cur, l) =+ let l' = addLines new l+ in case splitLinesOn (isPrompt (cur + 1)) l' of+ Nothing -> (done, cur, l')+ Just (before, after) ->+ let (newMap, newCur, newLines) = accumHandle isPrompt (unLines after) (Map.insert cur before done, cur+1, mempty)+ in (Map.union newMap done, newCur, newLines)++-- | Accumulate the output of stdout and stderr, grouping the output lines of both by prompt+accumHandles+ :: (Int -> ByteString -> Bool)+ -> These ByteString ByteString+ -> Accum+ -> Accum+accumHandles isPrompt new acc =+ let acc' = case new of+ This a -> acc+ { _accum_stdout = accumHandle isPrompt a $ _accum_stdout acc+ }+ That a -> acc+ { _accum_stderr = accumHandle isPrompt a $ _accum_stderr acc+ }+ These a b -> acc+ { _accum_stdout = accumHandle isPrompt a $ _accum_stdout acc+ , _accum_stderr = accumHandle isPrompt b $ _accum_stderr acc+ }+ -- This intersection represents the commands/output that we've already had the opportunity to report. Those commands can now be removed.+ oldIntersection = Map.intersection (fst3 $ _accum_stdout acc) (fst3 $ _accum_stderr acc)+ in Accum+ { _accum_stdout =+ ( (fst3 $ _accum_stdout acc') `Map.difference` oldIntersection -- Only include output of commands we haven't previously declared "done"+ , snd3 $ _accum_stdout acc'+ , thd3 $ _accum_stdout acc'+ )+ , _accum_stderr =+ ( (fst3 $ _accum_stderr acc') `Map.difference` oldIntersection -- Only include output of commands we haven't previously declared "done"+ , snd3 $ _accum_stderr acc'+ , thd3 $ _accum_stderr acc'+ )+ }++-- | Take all the pending output and consider it complete.+flushAccum :: Accum -> Accum+flushAccum (Accum (stdout, curout, stdoutLeftovers) (stderr, curerr, stderrLeftovers)) =+ Accum (Map.insert curout stdoutLeftovers stdout, curout+1, mempty) (Map.insert curerr stderrLeftovers stderr, curerr+1, mempty)++-- | Run a repl, feed it commands, and produce output grouped by those+-- commands. The repl in question must be able to print its prompt on both+-- stdout and stderr.+repl+ :: 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+ )+ => P.CreateProcess+ -- ^ Command to run to enter repl+ -> Event t [Command]+ -- ^ Commands to send to the repl+ -> (Int -> ByteString -> Bool)+ -- ^ Test for determining whether a line is the prompt we're waiting or+ -> m (Repl t)+repl runRepl cmds isPrompt = do+ let ix0 = 1+ n <- liftIO $ newIORef ix0+ newIxedInput <- performEvent $ ffor cmds $ \inputs -> do+ fmap Map.fromList $ forM inputs $ \input' -> do+ new_n <- liftIO $ atomicModifyIORef' n $ \n' -> (succ n', n')+ pure $ (new_n, input')+ ixedInput <- foldDyn Map.union Map.empty newIxedInput+ proc <- createProcess runRepl $ ProcessConfig+ { _processConfig_stdin = fmapMaybe sendCommands cmds+ , _processConfig_signal = never+ }+ pb <- getPostBuild+ exited <- performEventAsync $ ffor pb $ \_ cb ->+ liftIO $ void $ forkIO $ cb <=< P.waitForProcess $ _process_handle proc+ results <- foldDyn ($) (Accum (Map.empty, ix0, mempty) (Map.empty, ix0, mempty)) $ leftmost+ [ accumHandles isPrompt <$> align (_process_stdout proc) (_process_stderr proc)+ , flushAccum <$ exited+ ]+ let outerr = ffor results $ \(Accum o e) -> Map.intersectionWith (,) (fst3 o) (fst3 e)+ finished <- holdUniqDyn $ Map.intersectionWith (\inp (o, e) -> Cmd inp o e) <$> ixedInput <*> outerr+ let commandInProgress i (Accum o e) = (snd3 o,) $ case (Map.lookup (snd3 o) i) of+ Nothing -> Nothing+ Just inp -> Just $ Cmd inp (thd3 o) (thd3 e)+ started = commandInProgress <$> ixedInput <*> results+ pure $ Repl+ { _repl_process = proc+ , _repl_finished = updated finished+ , _repl_started = started+ , _repl_exited = exited+ }++-- * Output lines++-- | Accumulator for line-based output that keeps track of any dangling,+-- unterminated line+data Lines = Lines+ { _lines_terminated :: Seq C8.ByteString+ , _lines_unterminated :: Maybe C8.ByteString+ }+ deriving (Show, Eq, Ord, Read)++-- | Empty output+emptyLines :: Lines+emptyLines = Lines Seq.empty Nothing++-- | Add some raw output to a 'Lines'. This will chop the raw output up into lines.+addLines :: ByteString -> Lines -> Lines+addLines new (Lines t u) =+ let newLines = Seq.fromList $ filter (not . C8.null) (C8.lines new)+ in+ case u of+ Nothing -> if "\n" `C8.isSuffixOf` new+ then Lines (t <> newLines) Nothing+ else case Seq.viewr newLines of+ Seq.EmptyR -> Lines t Nothing+ (t' Seq.:> u') -> Lines (t <> t') (Just u')+ Just u' -> addLines (u' <> new) $ Lines t Nothing++-- | Convert a 'ByteString' into a 'Lines'+linesFromBS :: C8.ByteString -> Lines+linesFromBS = flip addLines mempty++instance Semigroup Lines where+ a <> b = addLines (unLines b) a++instance Monoid Lines where+ mempty = emptyLines++-- | Convert a 'Lines' back into a 'ByteString'+unLines :: Lines -> ByteString+unLines (Lines t u) =+ C8.unlines (toList t) <> fromMaybe "" u++-- | Convenience accessor for the last whole line received by a 'Lines'.+-- Ignores any unterminated line that may follow.+lastWholeLine :: Lines -> Maybe C8.ByteString+lastWholeLine (Lines t _) = case Seq.viewr t of+ Seq.EmptyR -> Nothing+ _ Seq.:> x -> Just x++-- | Split lines into two. The sequence that satisfies the predicate is+-- consumed and will not appear in either resulting 'Lines'.+splitLinesOn :: (ByteString -> Bool) -> Lines -> Maybe (Lines, Lines)+splitLinesOn test (Lines t u) = + let (before, after) = Seq.breakl test t+ in if Seq.null after then Nothing else Just (Lines before Nothing, Lines (Seq.drop 1 after) u)++-- * Commands to send to the repl++-- | A string that will be sent to the repl for evaluation. A newline will be+-- appended to the end of the string. 'Command's should not themselves contain newlines.+newtype Command = Command { unCommand :: ByteString }+ deriving (Show, Read, Eq, Ord)++-- | Constructs a 'Command' without checking for newlines. If there are+-- newlines in the input, things will not work properly.+unsafeCommand :: ByteString -> Command+unsafeCommand = Command++-- | Convert a 'ByteString' into a set of 'Command's. Any newlines found in the+-- input are considered 'Command' separators.+command :: ByteString -> [Command]+command = map Command . filter (not . C8.null) . C8.splitWith (=='\n')++-- | Convert a 'ByteString' into a set of 'Command's. Any newlines found in the+-- input are considered 'Command' separators.+commands :: [ByteString] -> [Command]+commands = map Command . filter (not . C8.null) . concatMap (C8.splitWith (=='\n'))++-- | Turn a command back into a 'ByteString'.+displayCommand :: Command -> ByteString+displayCommand = unCommand++-- | Convert commands to a format that can be sent over stdin+sendCommands :: [Command] -> Maybe (SendPipe ByteString)+sendCommands cmds = case cmds of+ [] -> Nothing+ xs -> Just $ SendPipe_Message (C8.intercalate "\n" (unCommand <$> xs) <> "\n")++-- * Misc++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++thd3 :: (a, b, c) -> c+thd3 (_, _, c) = c++-- * Testing++-- | A headless repl test that runs ghci, executes some commands, and checks that the output is as expected.+testRepl :: IO ()+testRepl = runHeadlessApp $ do+ _ <- liftIO $ Signals.installHandler Signals.sigINT (Signals.Catch (return ())) Nothing+ pb <- getPostBuild+ testCommands <- mkTestCommands+ let cmds = mergeWith (\a b -> a <> b)+ [ command (C8.intercalate "\n"+ [ ":set prompt-function \\_ x -> let s = \"\\n\" <> show x <> \"" <> promptPostfix <> "\\n\" in System.IO.hPutStr System.IO.stderr s >> pure s"+ , ":set -fno-break-on-exception"+ , ":set -fno-break-on-error"+ , ":set -v1"+ , ":set -fno-hide-source-paths"+ , ":set -ferror-spans"+ , ":set -fdiagnostics-color=never"+ , ":r"+ ]) <$ pb+ , testCommands+ ]+ rec (Repl _ finished _ exit) <- repl (P.shell "ghci") cmds $ \cur line -> (C8.pack (show cur) <> promptPostfix) == line+ output <- foldDyn Map.union Map.empty finished+ passed <- performEvent $ ffor (tagPromptlyDyn output exit) $ \o -> do+ liftIO $ print o+ liftIO $ putStrLn "testRepl:"+ r1 <- assertStdoutEq "Simple command (1+1)" (Map.lookup 9 o) "2"+ r2 <- assertStdoutEq "IO action (putStrLn)" (Map.lookup 10 o) "hello"+ r3 <- assertStderr "Not in scope error" (Map.lookup 11 o) (C8.isInfixOf "Variable not in scope: oops" . unLines)+ r4 <- assertStdoutEq "Simple command (2+2)" (Map.lookup 12 o) "4"+ r5 <- assertStdoutEq "Simple command (3+4)" (Map.lookup 13 o) "7"+ r6 <- assertStderr "Exception" (Map.lookup 14 o) (C8.isInfixOf "*** Exception" . unLines)+ r7 <- assertStdoutEq "Reload (:r)" (Map.lookup 15 o) "Ok, no modules loaded."+ r8 <- assertStdoutEq "Quit (:q)" (Map.lookup 16 o) "Leaving GHCi."+ pure $ and [r1, r2, r3, r4, r5, r6, r7, r8]+ performEvent $ ffor passed $ \case+ False -> error "Test failed"+ True -> pure ()+ where+ promptPostfix :: ByteString+ promptPostfix = "_reflex_ghci_prompt>"++-- | Constructs some testing commands that are fed in on a timer+mkTestCommands :: (PerformEvent t m, PostBuild t m, TriggerEvent t m, MonadIO (Performable m)) => m (Event t [Command])+mkTestCommands = do+ pb <- getPostBuild+ pb2 <- delay 1 pb+ pb3 <- delay 1.5 pb+ pb4 <- delay 2 pb+ pb5 <- delay 2.5 pb+ pb6 <- delay 3 pb+ pure $ fmap command $ mergeWith (\a b -> a <> "\n" <> b)+ [ "1+1" <$ pb2+ , "putStrLn \"hello\"" <$ pb3+ , "oops" <$ pb4+ , "2+2" <$ pb5+ , "4+3" <$ pb5+ , "let Just x = Nothing in print x" <$ pb5+ , ":r" <$ pb6+ , ":q" <$ pb6+ ]++-- | Check that stdout equals the given value+assertStdoutEq :: MonadIO m => String -> Maybe Cmd -> ByteString -> m Bool+assertStdoutEq str cmd expectation = assertHandleEq _cmd_stdout str cmd expectation++-- | Check that stderr equals the given value+assertStderrEq :: MonadIO m => String -> Maybe Cmd -> ByteString -> m Bool+assertStderrEq str cmd expectation = assertHandleEq _cmd_stderr str cmd expectation++-- | Test the contents of stderr+assertStderr :: MonadIO m => String -> Maybe Cmd -> (Lines -> Bool) -> m Bool+assertStderr = assertHandle _cmd_stderr++-- | Test the contents of stdout+assertStdout :: MonadIO m => String -> Maybe Cmd -> (Lines -> Bool) -> m Bool+assertStdout = assertHandle _cmd_stdout++-- | Check that a handle equals the given value+assertHandleEq :: MonadIO m => (Cmd -> Lines) -> String -> Maybe Cmd -> ByteString -> m Bool+assertHandleEq h str cmd expectation = assertHandle h str cmd (== Lines (Seq.singleton expectation) Nothing)++-- | Test the contents of a handle+assertHandle :: MonadIO m => (Cmd -> Lines) -> String -> Maybe Cmd -> (Lines -> Bool) -> m Bool+assertHandle h str cmd expectation = assertCmd str cmd (expectation . h)++-- | Test that a repl command and its output satisfy the predicate+assertCmd :: MonadIO m => String -> Maybe Cmd -> (Cmd -> Bool) -> m Bool+assertCmd str cmd expectation = liftIO $ do+ putStrLn $ "Testing: " <> str+ if ((expectation <$> cmd) == Just True)+ then do+ putStrLn $ "PASSED: " <> str+ pure True+ else do+ putStrLn $ "FAILED: " <> str+ pure False
src/Reflex/Vty/GHCi.hs view
@@ -3,192 +3,67 @@ - Description: Vty widgets useful when building your own GHCi runner -} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Reflex.Vty.GHCi where -import Control.Monad ((<=<), void)-import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Data.ByteString (ByteString)+import Control.Monad+import qualified Data.Map as Map+import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Graphics.Vty.Input as V import Reflex.Network-import Reflex.Process import Reflex.Process.GHCi import Reflex.Vty-import qualified Graphics.Vty.Input as V import qualified System.Process as P---- | Display the overall status of the GHCi session, including exit information in case GHCi has quit-statusDisplay- :: ( PostBuild t m- , MonadHold t m- , HasDisplayRegion t m- , HasImageWriter t m- , HasTheme t m- )- => Ghci t- -> m ()-statusDisplay g = do- pb <- getPostBuild- text <=< hold "" $ leftmost- [ statusMessage <$> updated (_ghci_status g)- , statusMessage <$> tag (current $ _ghci_status g) pb- , ("Command exited with " <>) . T.pack . show <$> _process_exit (_ghci_process g)- ]---- | A scrollable widget that displays a message at the bottom of the widget--- when there is additional content to view.-scrollableOutput- :: ( Reflex t- , HasDisplayRegion t m- , HasFocus t m- , HasFocusReader t m- , HasImageWriter t m- , HasInput t m- , HasLayout t m- , HasTheme t m- , MonadFix m- , MonadHold t m- , MonadNodeId m- , PostBuild t m- , HasDisplayRegion t m- , HasFocus t m- , HasFocusReader t m- , HasImageWriter t m- , HasInput t m- , HasLayout t m- )- => Behavior t ByteString- -> m ()-scrollableOutput out = col $ do- dh <- displayHeight- scroll <- tile flex $ scrollableText never $ T.decodeUtf8 <$> out- grout (fixed 1) $ text $- let f h (ix, n) = if n - ix + 1 > h- then "↓ More ↓"- else ""- in f <$> current dh <*> scroll---- | A scrollable widget that scrolls down as output goes past the end of the widget-scrollingOutput- :: ( Reflex t- , Monad m- , MonadHold t m- , MonadFix m- , HasDisplayRegion t m- , HasInput t m- , HasImageWriter t m- , HasTheme t m- )- => Dynamic t ByteString- -> m ()-scrollingOutput out = do- dh <- displayHeight- let scrollBy h (ix, n) =- if | ix == 0 && n <= h -> Nothing -- Scrolled to the top and we don't have to scroll down- | n > h && n - ix - h == 0 -> Just 1- | otherwise -> Nothing- rec scroll <- scrollableText (tagMaybe (scrollBy <$> current dh <*> scroll) $ updated out) $- T.decodeUtf8 <$> current out- return ()---- | Display the output GHCi produces when it's loading the requested modules (e.g., warnings)-ghciModuleStatus- :: ( MonadNodeId m- , PostBuild t m- , MonadHold t m- , MonadFix m- , Adjustable t m- , HasLayout t m- , HasImageWriter t m- , HasFocusReader t m- , HasDisplayRegion t m- , HasInput t m- , HasTheme t m- , HasFocus t m- )- => Ghci t- -> m ()-ghciModuleStatus g = col $ do- let ghciExit = _process_exit $ _ghci_process g- ghciExited <- hold False $ True <$ ghciExit- grout (fixed 3) $ boxStatic def $ statusDisplay g- out <- moduleOutput (not <$> ghciExited) g- tile flex $ void $- networkHold (scrollableOutput $ current out) $ ffor (_ghci_reload g) $- const $ scrollableOutput $ current out---- | Display the output of the expression GHCi is evaluating-ghciExecOutput- :: ( MonadHold t m- , MonadFix m- , Adjustable t m- , HasDisplayRegion t m- , HasInput t m- , HasImageWriter t m- , HasTheme t m- , HasInput t m- )- => Ghci t- -> m ()-ghciExecOutput g = do- ghciExited <- hold False $ True <$ _process_exit (_ghci_process g)- out <- execOutput (not <$> ghciExited) g- -- Rebuild the entire output widget so that we don't have to worry about resetting scroll state- _ <- networkHold (scrollingOutput out) $ ffor (_ghci_reload g) $ \_ -> scrollingOutput out- return ()---- | A widget that displays the module status and the execution status in two stacked, resizable panes-ghciPanes- :: ( Reflex t- , MonadFix m- , MonadHold t m- , MonadNodeId m- , PostBuild t m- , Adjustable t m- , HasInput t m- , HasImageWriter t m- , HasFocusReader t m- , HasDisplayRegion t m- , HasTheme t m- , HasLayout t m- , HasFocus t m- )- => Ghci t- -> m ()-ghciPanes g = void $ splitVDrag- (hRule doubleBoxStyle)- (ghciModuleStatus g)- (ghciExecOutput g)+import qualified Reflex.Process.Repl as Repl --- | Listen for ctrl-c (and any other provided exit events) and--- shutdown the Ghci process upon receipt-getExitEvent- :: ( PerformEvent t m- , MonadIO (Performable m)- , HasInput t m- )- => Ghci t- -> Event t a- -> m (Event t ())-getExitEvent g externalExitReq = do- exitReq <- keyCombo (V.KChar 'c', [V.MCtrl])- let exitReqs = leftmost- [ g <$ externalExitReq- , g <$ exitReq+-- | The main reflex-ghci widget+run :: String -> Maybe String -> IO ()+run cmd expr = mainWidget $ initManager_ $ do+ tabNavigation+ exit' <- keyCombo (V.KChar 'c', [V.MCtrl])+ exit <- keyCombo (V.KChar 'x', [V.MCtrl])+ rec Repl _ finished started readyToExit <- ghciWatch (P.shell cmd) (Repl.unsafeCommand . T.encodeUtf8 . T.pack <$> expr) reload ((() <$ exit) <> (() <$ exit') <> quit)+ oldCommands <- foldDyn ($) Map.empty $+ (\new old -> Map.fromList $ take 3 $ reverse $ Map.toList $ Map.union old new) <$> finished+ command <- holdDyn Nothing $ fmap Just $ leftmost+ [ fforMaybe (updated started) $ \(ix, x) -> (ix,) <$> x+ , fmapMaybe id $ fmap fst . Map.maxViewWithKey <$> finished ]- shutdown exitReqs+ let atPrompt = ffor started $ isNothing . snd+ errors = maybe False (hasErrors . snd) <$> command+ (reload, quit) <- col $ do+ r <- tile (fixed 3) $ row $ do+ grout flex $ boxStatic def $ text $ (\x -> if x then "Ready" else "Busy") <$> current atPrompt+ void $ networkView $ ffor errors $ \case+ True -> grout flex $ boxStatic def $ text "Error!"+ False -> grout flex $ boxStatic def $ text "All Good!"+ r <- tile flex $ button def $ text "Reload"+ q <- tile flex $ button def $ text "Quit"+ pure (r, q)+ let cmdbtn ix c = tile (fixed 3) $ button def $ text $ pure $+ T.pack (show ix) <> ": " <> (T.decodeUtf8 $ displayCommand $ _cmd_stdin c)+ oldE <- switchHold never <=< fmap (fmap leftmost) $ networkView $ ffor oldCommands $ \old -> forM (Map.toList old) $ \(ix, c) -> do+ go <- cmdbtn ix c+ pure $ ix <$ go+ currentCommand <- switchHold never <=< networkView $ ffor started $ \case+ (_, Nothing) -> pure never+ (ix, Just c) -> cmdbtn ix c --- | Shut down a given Ghci process-shutdown- :: ( PerformEvent t m- , MonadIO (Performable m)- )- => Event t (Ghci t)- -> m (Event t ())-shutdown exitReqs = do- performEvent $ ffor exitReqs $ \g ->- liftIO $ P.terminateProcess $ _process_handle $ _ghci_process g+ let showOutput (Cmd _ out err) = do+ _ <- tile flex $ boxStatic def $ scrollableText never $ pure $ T.decodeUtf8 . unLines $ out+ _ <- tile flex $ boxStatic def $ scrollableText never $ pure $ T.decodeUtf8 . unLines $ err+ pure ()++ void $ networkHold (void $ networkView $ maybe blank (showOutput . snd) <$> command) $ leftmost+ [ ffor (attachWithMaybe (flip Map.lookup) (current oldCommands) oldE) showOutput+ , ffor (attachWithMaybe (\a _ -> fmap snd a) (current command) currentCommand) showOutput+ ]+ pure r+ return $ () <$ readyToExit
+ tests/lib-pkg-name/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/lib-pkg-name/src/MyLib.hs view
@@ -0,0 +1,8 @@+module MyLib (someFunc) where++import MyLib.One+import MyLib.Two+import MyLib.Three++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ tests/lib-pkg-name/src/MyLib/One.hs view
@@ -0,0 +1,4 @@+module MyLib.One where++data One = One+ deriving Show
+ tests/lib-pkg-name/src/MyLib/Three.hs view
@@ -0,0 +1,4 @@+module MyLib.Four where++data Three = Three+ deriving Show
+ tests/lib-pkg-name/src/MyLib/Two.hs view
@@ -0,0 +1,4 @@+module MyLib.Two where++data Two = Two+ deriving Show
+ tests/lib-pkg-name/test-pkg2.cabal view
@@ -0,0 +1,28 @@+cabal-version: >=1.10+-- Initial package description 'test-pkg2.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name: test-pkg2+version: 0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+license: BSD3+license-file: LICENSE+author: Ali Abrar+maintainer: aliabrar@gmail.com+-- copyright:+-- category:+build-type: Simple+extra-source-files: CHANGELOG.md++library+ exposed-modules: MyLib+ MyLib.One+ MyLib.Two+ MyLib.Three+ -- other-modules:+ -- other-extensions:+ build-depends: base+ hs-source-dirs: src+ default-language: Haskell2010
tests/lib-pkg/src/MyLib.hs view
@@ -1,4 +1,4 @@-module MyLib (someFunc) where+module MyLib where import MyLib.One import MyLib.Two
tests/test.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE StandaloneDeriving #-} -import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import qualified Data.Map as Map import Reflex import Reflex.Host.Headless (runHeadlessApp)-import Reflex.Workflow (Workflow (..), workflow) import System.Directory (copyFile, getCurrentDirectory, withCurrentDirectory) import System.IO.Temp (withSystemTempDirectory) import qualified System.Process as P+import qualified Data.ByteString.Char8 as C8 import Reflex.Process.GHCi-import Reflex.Vty.GHCi ghciExe :: FilePath ghciExe = "ghci"@@ -22,222 +25,58 @@ data ExitStatus = Succeeded | Failed String deriving (Eq, Show) --- Simple tests with no reloading or interrupts:------ | Test | Module Status | Expression Status |--- |----------------------|-----------------------|---------------------------|--- | testModuleLoad | Status_LoadSucceeded | None |--- | testModuleLoadFailed | Status_LoadFailed | None |--- | testExprErr | Status_LoadSucceeded | Status_ExecutionFailed |--- | testExprNotFound | Status_LoadSucceeded | Status_ExecutionFailed |--- | testExprFinished | Status_LoadSucceeded | Status_ExecutionSucceeded |- main :: IO () main = do- src <- getCurrentDirectory- let cmd path load = P.proc ghciExe ["-i" <> src <> path, load]- putStrLn "Testing lib-pkg"- testLoadAndExecute $ cmd "/tests/lib-pkg/src" "MyLib"- putStrLn "Testing lib-exe"- testLoadAndExecute $ cmd "/tests/exe-pkg" "Main"- putStrLn "Testing lib-pkg-err" runHeadlessApp $ do- out <- testModuleLoadFailed $ cmd "/tests/lib-pkg-err/src" "MyLib"- failOnError out- exitOnSuccess out- putStrLn "Testing file watching and reloading"+ pb <- getPostBuild+ rec+ r <- ghci (P.shell ghciExe) expr never never+ let expr = commands + [ ":l tests/exe-pkg/Main.hs"+ , "main"+ , ":l tests/lib-pkg-err/src/MyLib/One.hs tests/lib-pkg-err/src/MyLib/Two.hs tests/lib-pkg-err/src/MyLib/Three.hs tests/lib-pkg-err/src/MyLib.hs"+ , ":l tests/lib-pkg/src/MyLib/One.hs tests/lib-pkg/src/MyLib/Two.hs tests/lib-pkg/src/MyLib/Three.hs tests/lib-pkg/src/MyLib.hs"+ , "import MyLib"+ , "err"+ , "notFound"+ , "done"+ , ":q"+ ] <$ pb+ results <- foldDyn Map.union Map.empty $ _repl_finished r+ performEvent_ $ ffor (tagPromptlyDyn results (_repl_exited r)) $ \o -> do+ liftIO $ print o+ liftIO $ putStrLn "Simple tests with no reloading or interrupts:"+ r1 <- assertStdoutEq "Load and run package (exe-pkg/Main.hs:main)" (Map.lookup 10 o) "Hello, Haskell!"+ r2 <- assertStderr "Fail to load package (lib-pkg-err)" (Map.lookup 11 o) (C8.isInfixOf "Multiple declarations" . unLines)+ r3 <- assertStdout "Load package (lib-pkg)" (Map.lookup 12 o) (C8.isInfixOf "Ok, four modules loaded" . unLines)+ r4 <- assertCmd "Exception (lib-pkg/src/MyLib.hs:err)" (Map.lookup 14 o) hasErrors+ r5 <- assertCmd "Variable not in scope (lib-pkg/src/MyLib.hs:notFound)" (Map.lookup 15 o) hasErrors+ r6 <- assertStdoutEq "Expression completed (lib-pkg/src/MyLib.hs:done)" (Map.lookup 16 o) "done"+ when (not . and $ [r1, r2, r3, r4, r5, r6]) $ error "Tests failed"+ pure $ () <$ _repl_exited r+ testRepl watchAndReloadTest -failOnError- :: ( PerformEvent t m- , Reflex t- )- => Event t ExitStatus -> m ()-failOnError out = performEvent_ $ fforMaybe out $ \case- Failed err -> Just $ error $ "Failed with: " <> err- Succeeded -> Nothing--exitOnSuccess- :: ( Reflex t- , Monad m- )- => Event t ExitStatus- -> m (Event t ())-exitOnSuccess out =- return $ () <$ ffilter (==Succeeded) out--testLoadAndExecute- :: P.CreateProcess- -> IO ()-testLoadAndExecute cmd = runHeadlessApp $ do- out <- switch . current <$> workflow (testModuleLoad cmd)- performEvent_ $ liftIO . print <$> out- failOnError out- exitOnSuccess out--type TestWorkflow t m = Workflow t m (Event t ExitStatus)--testModuleLoad- :: ( MonadIO m- , TriggerEvent t m- , PerformEvent t m- , MonadIO (Performable m)- , PostBuild t m- , MonadFix m- , MonadHold t m- )- => P.CreateProcess- -> TestWorkflow t m-testModuleLoad cmd = Workflow $ do- liftIO $ putStrLn "testModuleLoad"- g <- ghciWatch cmd Nothing- let loaded = fforMaybe (updated $ _ghci_status g) $ \case- Status_LoadSucceeded -> Just True- Status_LoadFailed -> Just False- _ -> Nothing- done <- afterShutdown g loaded- return ( Failed . show <$> ffilter not done- , testExprErr cmd <$ ffilter id done- )--testExprErr- :: ( MonadIO m- , TriggerEvent t m- , PerformEvent t m- , MonadIO (Performable m)- , PostBuild t m- , MonadFix m- , MonadHold t m- )- => P.CreateProcess- -> TestWorkflow t m-testExprErr cmd = Workflow $ do- liftIO $ putStrLn "testExprErr"- g <- ghciWatch cmd $ Just "err"- let exception = fforMaybe (updated $ _ghci_status g) $ \case- Status_ExecutionFailed -> Just True- Status_ExecutionSucceeded -> Just False- _ -> Nothing- done <- afterShutdown g exception- return ( Failed . show <$> ffilter not done- , testExprNotFound cmd <$ ffilter id done- )--testExprNotFound- :: ( MonadIO m- , TriggerEvent t m- , PerformEvent t m- , MonadIO (Performable m)- , PostBuild t m- , MonadFix m- , MonadHold t m- )- => P.CreateProcess- -> TestWorkflow t m-testExprNotFound cmd = Workflow $ do- liftIO $ putStrLn "testExprNotFound"- g <- ghciWatch cmd $ Just "notTheFunctionYoureLookingFor"- let exception = fforMaybe (updated $ _ghci_status g) $ \case- Status_ExecutionFailed -> Just True- Status_ExecutionSucceeded -> Just False- _ -> Nothing- done <- afterShutdown g exception- return ( Failed . show <$> ffilter not done- , testExprFinished cmd <$ ffilter id done- )--testExprFinished- :: ( MonadIO m- , TriggerEvent t m- , PerformEvent t m- , MonadIO (Performable m)- , PostBuild t m- , MonadFix m- , MonadHold t m- )- => P.CreateProcess- -> TestWorkflow t m-testExprFinished cmd = Workflow $ do- liftIO $ putStrLn "testExprFinished"- g <- ghciWatch cmd $ Just "done"- let finished = fforMaybe (updated $ _ghci_status g) $ \case- Status_ExecutionFailed -> Just False- Status_ExecutionSucceeded -> Just True- _ -> Nothing- done <- afterShutdown g finished- return ( outcome done- , never- )--outcome :: Functor f => f Bool -> f ExitStatus-outcome = fmap (\x -> if x then Succeeded else Failed (show x))- watchAndReloadTest :: IO () watchAndReloadTest = withSystemTempDirectory "reflex-ghci-test" $ \p -> do+ putStrLn "watchAndReloadTest:" src <- getCurrentDirectory P.callProcess "cp" ["-r", src <> "/tests/lib-pkg-err", p] let cmd = P.proc ghciExe ["-i" <> p <> "/lib-pkg-err/src", "MyLib"] withCurrentDirectory p $ runHeadlessApp $ do- g <- ghciWatch cmd Nothing- performEvent_ $ ffor (_ghci_moduleOut g) $ liftIO . print- performEvent_ $ ffor (_ghci_moduleErr g) $ liftIO . print- performEvent_ $ ffor (updated $ _ghci_status g) $ liftIO . print- let loadFailed = fforMaybe (updated $ _ghci_status g) $ \case- Status_LoadFailed -> Just ()- _ -> Nothing+ g <- ghciWatch cmd (Just (unsafeCommand ":q")) never never+ loadFailedDelayed <- debounce 0.5 $ ffilter id $ updated $ ffor (_repl_started g) $ \case+ (_, Nothing) -> True+ _ -> False - loadFailedDelayed <- delay 1 loadFailed -- If we respond too quickly, fsnotify won't deliver the change. performEvent_ $ ffor loadFailedDelayed $ \_ -> liftIO $ do putStrLn "copying fixed file" copyFile (src <> "/tests/lib-pkg/src/MyLib/Three.hs") (p <> "/lib-pkg-err/src/MyLib/Three.hs") - numFailures :: Dynamic t Int <- count loadFailed- let loadSucceeded = fforMaybe (updated $ _ghci_status g) $ \case- Status_LoadSucceeded -> Just ()- _ -> Nothing- performEvent_ $ fforMaybe (updated numFailures) $ \x ->- if x > 1- then Just $ error "Too many failures."- else Nothing-- afterShutdown g $ gate ((>= 1) <$> current numFailures) loadSucceeded--testModuleLoadFailed- :: ( MonadIO m- , TriggerEvent t m- , PerformEvent t m- , MonadIO (Performable m)- , PostBuild t m- , MonadFix m- , MonadHold t m- )- => P.CreateProcess- -> m (Event t ExitStatus)-testModuleLoadFailed cmd = do- liftIO $ putStrLn "testModuleLoadFailed"- g <- ghciWatch cmd Nothing- let loaded = fforMaybe (updated $ _ghci_status g) $ \case- Status_LoadSucceeded -> Just False- Status_LoadFailed -> Just True- _ -> Nothing- done <- afterShutdown g loaded- return $ ffor done $ \x ->- if x- then Succeeded- else Failed "testModuleFailed: lib-pkg-err shouldn't have loaded"---- | Utility to help use an 'Event' for stopping the network, but not until the shutdown is complete.-afterShutdown :: (PerformEvent t m, MonadIO (Performable m), MonadHold t m) => Ghci t -> Event t b -> m (Event t b)-afterShutdown g e = do- eValue <- hold Nothing $ Just <$> e- after <- shutdown $ g <$ e- pure $ fmapMaybe id $ tag eValue after+ output <- foldDyn Map.union Map.empty $ _repl_finished g -debug :: (Reflex t, PerformEvent t m, MonadIO (Performable m)) => Ghci t -> m ()-debug g = do- performEvent_ $ ffor (updated $ _ghci_status g) $ liftIO . print- performEvent_ $ ffor (_ghci_moduleOut g) $ liftIO . print- performEvent_ $ ffor (_ghci_moduleErr g) $ liftIO . print- performEvent_ $ ffor (_ghci_execOut g) $ liftIO . print- performEvent_ $ ffor (_ghci_execErr g) $ liftIO . print+ performEvent $ ffor (tagPromptlyDyn output (_repl_exited g)) $ \o -> do+ r1 <- assertCmd "Failed to load file" (Map.lookup 8 o) hasErrors+ r2 <- assertCmd "Changed file detected and loaded" (Map.lookup 9 o) (not . hasErrors)+ when (not . and $ [r1, r2]) $ error "Test failed"