Add ability to execute an expression on successful ghci load in "ghcid" example

reflex-vty.cabal

@@ -39,7 +39,6 @@ library
     data-default                      >= 0.7.1 && < 0.8,
     dependent-map                     >= 0.2.4 && < 0.4,
     dependent-sum                     >= 0.3 && < 0.7,
-    exception-transformers            >= 0.4.0 && < 0.5,
     mtl                               >= 2.2.2 && < 2.3,
     primitive                         >= 0.6.3 && < 0.7,
     process                           >= 1.6.4 && < 1.7,
@@ -50,6 +49,7 @@ library
     text-icu                          >= 0.7 && < 0.8,
     time                              >= 1.8.0 && < 1.9,
     transformers                      >= 0.5.5 && < 0.6,
+    unix,
     vty                               >= 5.21 && < 5.26
 
   hs-source-dirs: src
@@ -92,6 +92,7 @@ executable ghcid
   ghc-options: -threaded
   build-depends:
     base,
+    bytestring,
     containers,
     directory,
     filepath,
@@ -99,8 +100,11 @@ executable ghcid
     process,
     reflex,
     reflex-vty,
+    regex-tdfa,
     temporary,
+    time,
     text,
+    unix,
     vty
   default-language: Haskell2010
 

src-bin/ghcid.hs

@@ -1,20 +1,31 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 import Reflex.Process
 import Reflex.Vty
 
 import Control.Concurrent
+import Control.Exception (finally)
 import Control.Monad
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (liftIO, MonadIO)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
 import qualified Data.List as List
 import Data.Sequence (Seq)
+import Data.String (IsString)
+import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Graphics.Vty as V
+import Text.Regex.TDFA as Regex
+import Text.Regex.TDFA.ByteString ()
 import qualified System.Directory as Dir
 import qualified System.FilePath.Posix as FS
 import qualified System.FSNotify as FS
+import System.IO.Temp (withSystemTempDirectory)
+import qualified System.Posix.Signals as P
 import qualified System.Process as P
 
 watchDirectory
@@ -28,38 +39,122 @@ watchDirectory cfg path =
       _ <- FS.watchTree mgr p (const True) cb
       forever $ threadDelay 1000000
 
+prompt :: IsString a => a
+prompt = "~WAITING~"
+
 ghcid
   :: (TriggerEvent t m, PerformEvent t m, MonadIO (Performable m), PostBuild t m, MonadIO m, MonadFix m, MonadHold t m)
-  => m (Process t, Event t (Seq FS.Event))
-ghcid = do
+  => FilePath
+  -> m (Process t, Event t (Seq FS.Event), Dynamic t LoadState, Event t ())
+ghcid tempDir = do
   dir <- liftIO Dir.getCurrentDirectory
+  let dotGhci = tempDir FS.</> ".ghci"
+  liftIO $ writeFile dotGhci $ unlines
+    [ ":set prompt " <> prompt
+    ]
   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 ghcid.hs (this file) given the cabal repl command we're using.
-  -- We could use ":show modules" to see which hs files are loaded and determine what to do based 
+  -- We could use ":show modules" to see which hs files are loaded and determine what to do based
   -- on that.
-  let filteredFsEvents = flip ffilter fsEvents $ \e -> 
+  let filteredFsEvents = flip ffilter fsEvents $ \e ->
         let subpath = fmap FS.splitPath $ List.stripPrefix dir $ FS.eventPath e
         in case subpath of
              Nothing -> False
              Just s -> not $ List.isPrefixOf ["/", ".git/"] s || List.isPrefixOf ["/", "dist/"] s
   batchedFsEvents <- batchOccurrences 0.1 filteredFsEvents
-  proc <- createProcess (P.proc "cabal" ["repl", "ghcid", "--ghc-options=-Wall"]) $ ffor batchedFsEvents $ \_ -> ":r"
-  return (proc, batchedFsEvents)
+  let cabalRepl = (P.proc "cabal"
+        [ "repl"
+        , "ghcid"
+        , "--ghc-options=-Wall"
+        , "--ghc-options=-ignore-dot-ghci"
+        , "--ghc-options=-ghci-script " <> dotGhci
+        ]) { P.create_group = True }
+  rec proc <- createProcess cabalRepl $ ProcessConfig
+        { _processConfig_stdin = leftmost
+            [ reload
+            , fforMaybe (updated testMode) $ \case
+                True -> Just "test"
+                False -> Nothing
+            ]
+        , _processConfig_signal = never
+        }
+      let interruptible ls init = init && ls == LoadState_Loading
+          requestInterrupt = gate (interruptible <$> current loadState <*> initialized) batchedFsEvents
+      interrupt <- performEvent $ ffor requestInterrupt $
+        const $ liftIO $ P.interruptProcessGroupOf $ _process_handle proc
+      testMode <- holdDyn False $ leftmost
+        [ False <$ requestInterrupt
+        , False <$ reload
+        , fforMaybe (updated loadState) $ \case
+            LoadState_Succeeded -> Just True
+            LoadState_Failed -> Just False
+            _ -> Nothing
+        ]
+      let reload = ":r" <$ batchedFsEvents
+      output <- foldDyn ($) "" $ leftmost
+        [ flip mappend <$> _process_stdout proc
+        , const "Reloading...\n" <$ batchedFsEvents
+        ]
+      let loadState = ffor output $ \o ->
+            case reverse (C8.lines o) of
+              (expectedPrompt:expectedMessage:_) ->
+                if expectedPrompt == prompt
+                  then if expectedMessage Regex.=~ ("Ok.*module.*loaded." :: BS.ByteString)
+                    then LoadState_Succeeded
+                    else LoadState_Failed
+                  else LoadState_Loading
+              _ -> LoadState_Loading
+      initialized <- hold False $ fforMaybe (updated output) $ \o ->
+        if o Regex.=~ ("GHCi, version.*: http://www.haskell.org/ghc/" :: BS.ByteString)
+          then Just True
+          else Nothing
+  return (proc, batchedFsEvents, loadState, interrupt)
   where
     noDebounce :: FS.WatchConfig -> FS.WatchConfig
     noDebounce cfg = cfg { FS.confDebounce = FS.NoDebounce }
 
+data Ghci t = Ghci
+  { _ghci_moduleOut :: Event t BS.ByteString
+  , _ghci_moduleErr :: Event t BS.ByteString
+  , _ghci_execOut :: Event t BS.ByteString
+  , _ghci_execErr :: Event t BS.ByteString
+  , _ghci_filesystem :: Event t FS.Event
+  , _ghci_loadState :: Dynamic t LoadState
+  }
+
+data LoadState
+  = LoadState_Loading
+  | LoadState_Failed
+  | LoadState_Succeeded
+  deriving (Show, Read, Eq, Ord)
+
 main :: IO ()
-main = mainWidget $ do
+main = withSystemTempDirectory "reflex-ghcid" $ \tempDir -> mainWidget $ do
   exit <- keyCombo (V.KChar 'c', [V.MCtrl])
-  (p, fs) <- ghcid
   col $ do
+    (p, fs, ready, interrupt) <- fixed 1 $ ghcid tempDir
     output <- foldDyn ($) "" $ leftmost
-      [ flip mappend <$> _process_stdout p 
+      [ flip mappend <$> _process_stdout p
       , flip mappend <$> _process_stderr p
       , const "" <$ fs
       ]
+    fixed 3 $ boxStatic def $ text $ (<>) <$> "Status: " <*> ffor (current ready) (\case
+      LoadState_Succeeded -> "Success!"
+      LoadState_Failed -> "Failure!"
+      LoadState_Loading -> "Loading...")
     stretch $ text $ T.decodeUtf8 <$> current output
+    fixed 1 $ display <=< hold Nothing $ Just <$> _process_signal p
+    fixed 1 $ display <=< hold Nothing $ leftmost [ Just <$> interrupt, Nothing <$ fs ]
   return $ () <$ exit
+
+test :: IO ()
+test = do
+  let go :: Int -> IO ()
+      go n = putStrLn ("Iteration No. " <> show n) >> threadDelay 1000000 >> go (n+1)
+  go 1
+  return ()
+
+-- TODO
+-- Wait until ghci loads before allowing any interrupts

src/Reflex/Process.hs

@@ -8,9 +8,11 @@ module Reflex.Process
   ( createProcess
   , createRedirectedProcess
   , Process(..)
+  , ProcessConfig(..)
   ) where
 
 import Control.Concurrent (forkIO, killThread)
+import Control.Exception (mask_)
 import Control.Monad (void, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.ByteString (ByteString)
@@ -19,16 +21,25 @@ import qualified Data.ByteString.Char8 as Char8
 import qualified GHC.IO.Handle as H
 import GHC.IO.Handle (Handle)
 import System.Exit (ExitCode)
+import qualified System.Posix.Signals as P
 import qualified System.Process as P
 import System.Process hiding (createProcess)
 
 import Reflex
 
+-- | The inputs to a process
+data ProcessConfig t = ProcessConfig
+  { _processConfig_stdin :: Event t ByteString
+  , _processConfig_signal :: Event t P.Signal
+  }
+
 -- | The output of a process
 data Process t = Process
-  { _process_exit :: Event t ExitCode
+  { _process_handle :: P.ProcessHandle
   , _process_stdout :: Event t ByteString
   , _process_stderr :: Event t ByteString
+  , _process_exit :: Event t ExitCode
+  , _process_signal :: Event t P.Signal
   }
 
 -- | Runs a process and uses the given input and output handler functions
@@ -44,9 +55,9 @@ createRedirectedProcess
   -> (Handle -> (ByteString -> IO ()) -> IO (IO ()))
   -- ^ Builder for the stdout and stderr handlers
   -> CreateProcess
-  -> Event t ByteString
+  -> ProcessConfig t
   -> m (Process t)
-createRedirectedProcess mkWriteInput mkReadOutput p input = do
+createRedirectedProcess mkWriteInput mkReadOutput p (ProcessConfig input signal) = do
   let redirectedProc = p
         { std_in = CreatePipe
         , std_out = CreatePipe
@@ -57,6 +68,12 @@ createRedirectedProcess mkWriteInput mkReadOutput p input = do
     (Just hIn, Just hOut, Just hErr) -> do
       writeInput <- liftIO $ mkWriteInput hIn
       performEvent_ $ liftIO . writeInput <$> input
+      sigOut <- performEvent $ ffor signal $ \sig -> liftIO $ do
+        mpid <- P.getPid ph
+        case mpid of
+          Nothing -> return Nothing
+          Just pid -> do
+            P.signalProcess sig pid >> return (Just sig)
       let output h = do
             (e, trigger) <- newTriggerEvent
             reader <- liftIO $ mkReadOutput h trigger
@@ -65,7 +82,7 @@ createRedirectedProcess mkWriteInput mkReadOutput p input = do
       (out, outThread) <- output hOut
       (err, errThread) <- output hErr
       (ecOut, ecTrigger) <- newTriggerEvent
-      void $ liftIO $ forkIO $ waitForProcess ph >>= \ec -> do
+      void $ liftIO $ forkIO $ waitForProcess ph >>= \ec -> mask_ $ do
         ecTrigger ec
         P.cleanupProcess po
         killThread outThread
@@ -74,6 +91,8 @@ createRedirectedProcess mkWriteInput mkReadOutput p input = do
         { _process_exit = ecOut
         , _process_stdout = out
         , _process_stderr = err
+        , _process_signal = fmapMaybe id sigOut
+        , _process_handle = ph
         }
     _ -> error "Reflex.Vty.Process.createRedirectedProcess: Created pipes were not returned by System.Process.createProcess."
 
@@ -86,14 +105,20 @@ createRedirectedProcess mkWriteInput mkReadOutput p input = do
 createProcess
   :: (MonadIO m, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
   => CreateProcess
-  -> Event t ByteString
+  -> ProcessConfig t
   -> m (Process t)
 createProcess = createRedirectedProcess input output
   where
     input h = do
       H.hSetBuffering h H.NoBuffering
-      return $ Char8.hPutStrLn h
+      let go b = do
+            open <- H.hIsOpen h
+            when open $ do
+              writable <- H.hIsWritable h
+              when writable $ Char8.hPutStrLn h b
+      return go
     output h trigger = do
+      H.hSetBuffering h H.LineBuffering
       let go = do
             open <- H.hIsOpen h
             readable <- H.hIsReadable h