diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for reflex-ghci + +## 0.1.0.0 + +* Initial release. A reflex-process wrapper for GHCi and cabal repl commands and a reflex-vty-based executable. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Obsidian Systems LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Obsidian Systems LLC nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +reflex-ghci +============== + +[![hackage](https://img.shields.io/hackage/v/reflex-ghci.svg)](https://hackage.haskell.org/package/reflex-ghci) [![hackage-ci](https://matrix.hackage.haskell.org/api/v2/packages/reflex-ghci/badge)](https://matrix.hackage.haskell.org/#/package/reflex-ghci) [![travis-ci](https://api.travis-ci.org/reflex-frp/reflex-ghci.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-ghci) + +Library +------- +A functional-reactive wrapper around GHCi that uses filesystem notifications to automatically reload haskell source files. + +Executable +---------- + +![screenshot](screenshot.png) + +This package includes a [reflex-vty](https://github.com/reflex-frp/reflex-vty)-based executable, shown above. Module information (errors, warnings, etc) is shown in a scrollable pane on the top half of the screen and the output of any expression you (optionally) choose to evaluate is shown in a scrollable pane on the bottom half. The panes are resizable using the mouse. + +```bash +$ reflex-ghci -h +Welcome to reflex-ghci! + +Usage: [-c|--command COMMAND] [-e|--expression EXPR] + Run a Haskell REPL that automatically reloads when source files change. + +Available options: + -c,--command COMMAND The ghci/cabal repl command to + run (default: "cabal repl") + -e,--expression EXPR The optional expression to evaluate once modules have + successfully loaded (default: no expression) + -h,--help Show this help text +``` + +Acknowledgements +---------------- +Inspired by the fantastic [ghcid](https://github.com/ndmitchell/ghcid) project. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/reflex-ghci.cabal b/reflex-ghci.cabal new file mode 100644 --- /dev/null +++ b/reflex-ghci.cabal @@ -0,0 +1,59 @@ +cabal-version: >=1.10 +name: reflex-ghci +version: 0.1.0.0 +synopsis: A GHCi widget library for use in reflex applications +description: + Run GHCi from within a reflex application and interact with it using a functional-reactive interface. + . + <> + . +bug-reports: https://github.com/reflex-frp/reflex-ghci/issues +license: BSD3 +license-file: LICENSE +author: Obsidian Systems LLC +maintainer: maintainer@obsidian.systems +copyright: 2020 Obsidian Systems LLC +category: FRP, Development, +build-type: Simple +extra-source-files: ChangeLog.md + README.md + screenshot.png +tested-with: GHC ==8.6.5 + +library + exposed-modules: Reflex.Process.GHCi + build-depends: + base >= 4.12 && < 4.13 + , bytestring >= 0.10 && < 0.11 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.5 + , fsnotify >= 0.3 && < 0.4 + , process >= 1.6 && < 1.7 + , reflex >= 0.6.3 && < 0.7 + , reflex-fsnotify >= 0.1 && < 0.2 + , reflex-process >= 0.1 && < 0.2 + , regex-tdfa >= 1.2.3 && < 1.3 + , unix >= 2.7 && < 2.8 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable reflex-ghci + hs-source-dirs: src-bin + main-is: ghci.hs + build-depends: + base >= 4.12 && < 4.13 + , optparse-applicative >= 0.14.0 && < 0.16 + , process >= 1.6 && < 1.7 + , reflex >= 0.6.3 && < 0.7 + , reflex-ghci + , reflex-vty >= 0.1.3 && < 0.2 + , reflex-process >= 0.1 && < 0.2 + , text >= 1.2 && < 1.3 + , vty >= 5.25 && < 5.26 + ghc-options: -threaded + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/reflex-frp/reflex-ghci diff --git a/screenshot.png b/screenshot.png new file mode 100644 Binary files /dev/null and b/screenshot.png differ diff --git a/src-bin/ghci.hs b/src-bin/ghci.hs new file mode 100644 --- /dev/null +++ b/src-bin/ghci.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +import Reflex.Network +import Reflex.Process +import Reflex.Process.GHCi +import Reflex.Vty + +import Control.Concurrent (threadDelay) +import Control.Monad (void, (<=<)) +import qualified Graphics.Vty.Input as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import System.Environment (getArgs) +import System.Process (shell) + +import Options.Applicative + +data GhciArg = GhciArg + { _ghciArg_replCommand :: String + , _ghciArg_execCommand :: Maybe String + } + +ghciArg :: Parser GhciArg +ghciArg = GhciArg + <$> strOption + ( long "command" <> + short 'c' <> + help "The ghci/cabal repl command to run" <> + showDefault <> + value "cabal repl" <> + metavar "COMMAND" + ) + <*> optional (strOption + ( long "expression" <> + short 'e' <> + help "The optional expression to evaluate once modules have successfully loaded" <> + showDefaultWith (\case + "" -> "no expression" + expr -> expr) <> + value "" <> + metavar "EXPR" + )) + +main :: IO () +main = do + let opts = info (ghciArg <**> helper) $ mconcat + [ fullDesc + , progDesc "Run a Haskell REPL that automatically reloads when source files change." + , header "Welcome to reflex-ghci!" + ] + GhciArg { _ghciArg_replCommand = cmd, _ghciArg_execCommand = expr } <- execParser opts + mainWidget $ do + exit <- keyCombo (V.KChar 'c', [V.MCtrl]) + g <- ghciWatch (shell cmd) $ T.encodeUtf8 . T.pack <$> expr + pb <- getPostBuild + let ghciExit = _process_exit (_ghci_process g) + ghciExited <- hold False $ True <$ ghciExit + let ghciLoadStatus = col $ do + fixed 3 $ boxStatic def $ text <=< hold "" $ leftmost + [ statusMessage <$> updated (_ghci_status g) + , statusMessage <$> tag (current $ _ghci_status g) pb + , ("Command exited with " <>) . T.pack . show <$> ghciExit + ] + out <- moduleOutput (not <$> ghciExited) g + (dh, scroll) <- stretch $ do + dh <- displayHeight + scroll <- scrollableText never $ T.decodeUtf8 <$> current out + return (dh, scroll) + fixed 1 $ text $ (\h (ix, n) -> if n - ix + 1 > h then "↓ More ↓" else "") <$> current dh <*> scroll + ghciExecOutput = do + out <- (T.decodeUtf8 <$>) <$> execOutput (not <$> ghciExited) g + let scrollingOutput = do + dh <- displayHeight + rec scroll <- scrollableText (tagMaybe (scrollBy <$> current dh <*> scroll) $ updated out) $ current out + 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 + return () + -- Rebuild the entire output widget so that we don't have to worry about resetting scroll state + _ <- networkHold scrollingOutput $ ffor (_ghci_reload g) $ \_ -> scrollingOutput + return () + case expr of + Nothing -> ghciLoadStatus + Just _ -> void $ splitVDrag (hRule doubleBoxStyle) ghciLoadStatus ghciExecOutput + return $ () <$ exit + +test :: IO () +test = do + let go :: Int -> IO () + go n = putStrLn ("Iteration No. " <> show n) >> threadDelay 1000000 >> go (n+1) + -- error "asdf" + -- Just n <- return (Nothing :: Maybe Int) + go 1 + -- putStrLn "Done" diff --git a/src/Reflex/Process/GHCi.hs b/src/Reflex/Process/GHCi.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Process/GHCi.hs @@ -0,0 +1,277 @@ +{-| + - 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 (watchDirectory) +import Reflex.Process (ProcessConfig(..), Process(..), 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.Process as P +import qualified Text.Regex.TDFA as Regex ((=~)) + +-- | Runs a GHCi process and reloads it whenever the provided event fires +ghci + :: ( TriggerEvent t m + , PerformEvent t m + , MonadIO (Performable m) + , PostBuild t m + , MonadIO m + , MonadFix m + , MonadHold t m + ) + => P.CreateProcess + -- ^ Command to run to enter GHCi + -> Maybe ByteString + -- ^ Expression to evaluate whenever GHCi successfully loads modules + -> Event t () + -- ^ Ask GHCi to reload + -> m (Ghci t) +ghci p mexpr reloadReq = do + + let cmd = p { P.create_group = True } -- Need to set this so that group interrupts don't impact parent + + -- Run the process and feed it some input: + rec proc <- createProcess cmd $ ProcessConfig + { _processConfig_stdin = leftmost + [ reload + -- Execute some expression if GHCi is ready to receive it + , fforMaybe (updated status) $ \case + Status_LoadSucceeded -> mexpr + _ -> Nothing + -- On first load, set the prompt + , let f old new = if old == Status_Initializing && new == Status_Loading + then Just $ C8.intercalate "\n" + [ "Prelude.putStrLn \"Initialized. Setting up reflex-ghci...\"" + , ":set prompt ..." + , ":set -fno-break-on-exception" + , ":set -fno-break-on-error" + , ":set prompt \"\"" + , "Prelude.putStrLn \"\"" + , ":set prompt " <> prompt + , ":r" + ] + else Nothing + in attachWithMaybe f (current status) (updated status) + ] + , _processConfig_signal = never + } + + -- 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) + performEvent_ $ ffor requestInterrupt $ + const $ liftIO $ P.interruptProcessGroupOf $ _process_handle proc + + -- Define some Regex patterns to use to determine GHCi's state based on output + let okModulesLoaded = "Ok.*module.*loaded." :: ByteString + failedNoModulesLoaded = "Failed, no modules 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 = ":.*:.*:.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.*: http://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 -> \case + Status_Executing -> Status_ExecutionSucceeded + s -> s + | lastLine Regex.=~ ghciVersionMessage -> const Status_Loading + | otherwise -> \case + Status_LoadSucceeded -> case mexpr of + Nothing -> Status_LoadSucceeded + Just _ -> Status_Executing + s -> s + _ -> 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 + ] + + -- 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 |>" + +-- | 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 p mexec = do + -- Get the current directory so we can observe changes in it + dir <- liftIO getCurrentDirectory + + -- TODO: Separate the filesystem event logic into its own function + -- Watch the project directory for changes + pb <- getPostBuild + fsEvents <- watchDirectory (noDebounce FS.defaultConfig) (dir <$ pb) + + -- 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. + let filteredFsEvents = flip ffilter fsEvents $ \e -> + takeExtension (FS.eventPath e) `elem` [".hs", ".lhs"] + + -- Events are batched because otherwise we'd get several updates corresponding to one + -- user-level change. For example, saving a file in vim results in an event claiming + -- the file was removed followed almost immediately by an event adding the file + batchedFsEvents <- batchOccurrences 0.1 filteredFsEvents + + -- 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 } + +-- | 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 + } + +-- | 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) + +-- | 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] + +-- | 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] + +-- | 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 + ] + +-- | 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!"