reflex-ghci 0.1.3.1 → 0.1.4.0

raw patch · 7 files changed

+391/−10 lines, 7 filesdep +dependent-sumdep +mtldep +primitivedep ~basedep ~bytestringdep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dependent-sum, mtl, primitive, ref-tf, temporary

Dependency ranges changed: base, bytestring, directory, process, reflex, reflex-process, reflex-vty, text, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• reflex-ghci.cabal +28/−3
• src-bin/ghci.hs +6/−4
• src/Reflex/Process/GHCi.hs +1/−1
• src/Reflex/Vty/GHCi.hs +36/−2
• tests/HeadlessHost.hs +83/−0
• tests/test.hs +229/−0

@@ -1,5 +1,13 @@ # Revision history for reflex-ghci +## 0.1.4.0++* Library: Export `shutdown` and `getExitEvent` to make it easier for library users to cleanly exit+* Library: Fix regex to capture "Failed, one module loaded"+* Tests: Add basic test suite, covering module loading, expression execution, exceptions, and filesystem notification-based reloading.+* Library: Reset module output pane scroll position on reload events (like we do with the expression output pane).+* Executable: Show executable version number (taken from cabal file) in help output+ ## 0.1.3.1  * Update for compatibility with `reflex-process`-0.2.0.0.

@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: reflex-ghci-version: 0.1.3.1+version: 0.1.4.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.@@ -33,11 +33,12 @@     , process >= 1.6 && < 1.7     , reflex >= 0.6.3 && < 0.7     , reflex-fsnotify >= 0.2 && < 0.3-    , reflex-process >= 0.2 && < 0.3+    , reflex-process >= 0.2.1 && < 0.3     , regex-tdfa >= 1.2.3 && < 1.3     , reflex-vty >= 0.1.3 && < 0.2     , text >= 1.2 && < 1.3     , unix >= 2.7 && < 2.8+    , vty >= 5.25 && < 5.26   hs-source-dirs: src   default-language: Haskell2010   ghc-options: -Wall@@ -54,7 +55,31 @@     , reflex-vty     , reflex-process     , text-    , vty >= 5.25 && < 5.26+    , vty+  other-modules: Paths_reflex_ghci+  ghc-options: -threaded -rtsopts+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: test.hs+  hs-source-dirs: tests+  build-depends:+      base+    , bytestring+    , dependent-sum >= 0.6 && < 0.7+    , directory+    , mtl >= 2.2 && < 2.3+    , primitive >= 0.6.4 && < 0.7+    , process+    , ref-tf >= 0.4 && < 0.5+    , reflex+    , reflex-ghci+    , reflex-process+    , reflex-vty+    , temporary >= 1.3 && < 1.4+    , text+  other-modules: HeadlessHost   ghc-options: -threaded -rtsopts   default-language: Haskell2010 

@@ -5,12 +5,13 @@  import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO)-import qualified Graphics.Vty.Input as V import qualified Data.Text as T import qualified Data.Text.Encoding as T-import System.Process (shell, terminateProcess)-+import Data.Version (showVersion)+import qualified Graphics.Vty.Input as V import Options.Applicative+import Paths_reflex_ghci (version)+import System.Process (shell, terminateProcess)  data GhciArg = GhciArg   { _ghciArg_replCommand :: String@@ -39,7 +40,8 @@   let opts = info (ghciArg <**> helper) $ mconcat         [ fullDesc         , progDesc "Run a Haskell REPL that automatically reloads when source files change."-        , header "Welcome to reflex-ghci!"+        , header $ "Welcome to reflex-ghci " <>+            showVersion version         ]   GhciArg { _ghciArg_replCommand = cmd, _ghciArg_execCommand = expr } <- execParser opts   mainWidget $ do

@@ -95,7 +95,7 @@        -- Define some Regex patterns to use to determine GHCi's state based on output       let okModulesLoaded = "Ok.*module.*loaded." :: ByteString-          failedNoModulesLoaded = "Failed,.*modules 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?

@@ -10,6 +10,7 @@  import Control.Monad ((<=<), void) import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (liftIO, MonadIO) import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -17,6 +18,8 @@ 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@@ -75,9 +78,10 @@ -- | Display the output GHCi produces when it's loading the requested modules (e.g., warnings) ghciModuleStatus   :: ( MonadNodeId m-     , PostBuild t m +     , PostBuild t m      , MonadHold t m      , MonadFix m+     , Adjustable t m      )   => Ghci t   -> VtyWidget t m ()@@ -86,7 +90,9 @@   ghciExited <- hold False $ True <$ ghciExit   fixed 3 $ boxStatic def $ statusDisplay g   out <- moduleOutput (not <$> ghciExited) g-  stretch $ scrollableOutput $ current out+  stretch $ void $+    networkHold (scrollableOutput $ current out) $ ffor (_ghci_reload g) $+      const $ scrollableOutput $ current out  -- | Display the output of the expression GHCi is evaluating ghciExecOutput@@ -118,3 +124,31 @@   (hRule doubleBoxStyle)   (ghciModuleStatus g)   (ghciExecOutput g)++-- | Listen for ctrl-c (and any other provided exit events) and+-- shutdown the Ghci process upon receipt+getExitEvent+  :: ( PerformEvent t m+     , MonadIO (Performable m)+     )+  => Ghci t+  -> Event t a+  -> VtyWidget t m (Event t ())+getExitEvent g externalExitReq = do+  exitReq <- keyCombo (V.KChar 'c', [V.MCtrl])+  let exitReqs = leftmost+        [ g <$ externalExitReq+        , g <$ exitReq+        ]+  shutdown exitReqs++-- | 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

@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+module HeadlessHost where++import Data.Maybe+import Reflex+import Control.Monad.Fix+import Control.Monad.Primitive+import Reflex.Host.Class+import Control.Monad.IO.Class+import Control.Monad.Ref+import Data.IORef+import Data.Dependent.Sum+import Control.Concurrent.Chan (newChan, readChan)+import Control.Monad (forM, forM_)+import Control.Monad.Identity (Identity(..))++type HeadlessResult t = Event t ()++type MonadHeadlessApp t m =+  ( Reflex t+  , MonadHold t m+  , MonadFix m+  , PrimMonad (HostFrame t)+  , ReflexHost t+  , MonadIO (HostFrame t)+  , Ref m ~ IORef+  , Ref (HostFrame t) ~ IORef+  , MonadRef (HostFrame t)+  , NotReady t m+  , TriggerEvent t m+  , PostBuild t m+  , PerformEvent t m+  , MonadIO m+  , MonadIO (Performable m)+  , Adjustable t m+  )++runHeadlessApp+  :: (forall t m. MonadHeadlessApp t m => m (HeadlessResult t))+  -> IO ()+runHeadlessApp guest =+  (runSpiderHost :: SpiderHost Global a -> IO a) $ do+    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef+    events <- liftIO newChan+    (vtyResult, fc@(FireCommand fire)) <- do+      hostPerformEventT $+        flip runPostBuildT postBuild $+          flip runTriggerEventT events $+            guest+    mPostBuildTrigger <- readRef postBuildTriggerRef+    forM_ mPostBuildTrigger $ \postBuildTrigger ->+      fire [postBuildTrigger :=> Identity ()] $ return ()+    shutdown <- subscribeEvent vtyResult+    fix $ \loop -> do+      ers <- liftIO $ readChan events+      stop <- fireEventTriggerRefs fc ers $ readEvent shutdown >>= \case+        Nothing -> return False+        Just _ -> return True+      if or stop+        then return ()+        else loop+  where+    -- TODO Some part of this is probably general enough to belong in reflex+    -- | Use the given 'FireCommand' to fire events that have subscribers+    -- and call the callback for the 'TriggerInvocation' of each.+    fireEventTriggerRefs+      :: (Monad (ReadPhase m), MonadIO m)+      => FireCommand t m+      -> [DSum (EventTriggerRef t) TriggerInvocation]+      -> ReadPhase m a+      -> m [a]+    fireEventTriggerRefs (FireCommand fire) ers rcb = do+      mes <- liftIO $+        forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do+          me <- readIORef er+          return $ fmap (\e -> e :=> Identity a) me+      a <- fire (catMaybes mes) rcb+      liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb+      return a

@@ -0,0 +1,229 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+import HeadlessHost+import Reflex+import Reflex.Process.GHCi+import Reflex.Vty+import Reflex.Vty.GHCi+import Reflex.Workflow++import Control.Monad (void)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Data.ByteString (ByteString)+import qualified System.Process as P+import System.Directory+import System.Environment+import System.IO.Temp++ghciExe :: FilePath+ghciExe = "ghci"++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 = withSystemTempDirectory "reflex-ghci-test" $ \tmpdir -> 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"+  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+  void $ shutdown $ g <$ loaded+  return ( Failed . show <$> ffilter not loaded+         , testExprErr cmd <$ ffilter id loaded+         )++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+  void $ shutdown $ g <$ exception+  return ( Failed . show <$> ffilter not exception+         , testExprNotFound cmd <$ ffilter id exception+         )++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+  void $ shutdown $ g <$ exception+  return ( Failed . show <$> ffilter not exception+         , testExprFinished cmd <$ ffilter id exception+         )++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 done = fforMaybe (updated $ _ghci_status g) $ \case+          Status_ExecutionFailed -> Just False+          Status_ExecutionSucceeded -> Just True+          _ -> Nothing+  void $ shutdown $ g <$ done+  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+  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+    numFailures :: Dynamic t Int <- count loadFailed+    performEvent_ $ ffor loadFailed $ \_ -> liftIO $ do+      putStrLn "copying fixed file"+      P.callProcess "cp"+        [ src <> "/tests/lib-pkg/src/MyLib/Three.hs"+        , p <> "/lib-pkg-err/src/MyLib/Three.hs"+        ]+    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+    return 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+  void $ shutdown $ g <$ loaded+  return $ ffor loaded $ \x ->+    if x+      then Succeeded+      else Failed "testModuleFailed: lib-pkg-err shouldn't have loaded"