Add "ghcid" example

reflex-vty.cabal

@@ -77,6 +77,25 @@ executable process
   ghc-options: -threaded
   build-depends:
     base,
+    fsnotify,
+    process,
+    reflex,
+    reflex-vty,
+    temporary,
+    text,
+    vty
+  default-language: Haskell2010
+
+executable ghcid
+  hs-source-dirs: src-bin
+  main-is: ghcid.hs
+  ghc-options: -threaded
+  build-depends:
+    base,
+    containers,
+    directory,
+    filepath,
+    fsnotify,
     process,
     reflex,
     reflex-vty,

src-bin/ghcid.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Reflex.Process
+import Reflex.Vty
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import qualified Data.List as List
+import Data.Sequence (Seq)
+import qualified Data.Text.Encoding as T
+import qualified Graphics.Vty as V
+import qualified System.Directory as Dir
+import qualified System.FilePath.Posix as FS
+import qualified System.FSNotify as FS
+import qualified System.Process as P
+
+watchDirectory
+  :: (Reflex t, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
+  => FS.WatchConfig
+  -> Event t FilePath
+  -> m (Event t FS.Event)
+watchDirectory cfg path =
+  performEventAsync $ ffor path $ \p cb -> liftIO $ void $ forkIO $
+    FS.withManagerConf cfg $ \mgr -> do
+      _ <- FS.watchTree mgr p (const True) cb
+      forever $ threadDelay 1000000
+
+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
+  dir <- liftIO Dir.getCurrentDirectory
+  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 
+  -- on that.
+  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)
+  where
+    noDebounce :: FS.WatchConfig -> FS.WatchConfig
+    noDebounce cfg = cfg { FS.confDebounce = FS.NoDebounce }
+
+main :: IO ()
+main = mainWidget $ do
+  exit <- keyCombo (V.KChar 'c', [V.MCtrl])
+  (p, fs) <- ghcid
+  col $ do
+    output <- foldDyn ($) "" $ leftmost
+      [ flip mappend <$> _process_stdout p 
+      , flip mappend <$> _process_stderr p
+      , const "" <$ fs
+      ]
+    stretch $ text $ T.decodeUtf8 <$> current output
+  return $ () <$ exit

src-bin/process.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -5,10 +6,13 @@ import Reflex.Network
 import Reflex.Process
 import Reflex.Vty
 
+import Control.Concurrent
 import Control.Monad
+import Control.Monad.IO.Class (liftIO, MonadIO)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Graphics.Vty as V
+import qualified System.FSNotify as FS
 import qualified System.Process as P
 import System.IO.Temp (withSystemTempDirectory)
 
@@ -19,48 +23,62 @@ main = withSystemTempDirectory "asdf" $ \fp -> mainWidget $ do
   col $ do
     fixed 6 $ boxStatic def $ col $ do
       fixed 1 $ text "Call the date command every second and display the result."
-      out <- fixed 2 $ fmap (switch . current) $ networkHold (return never) $ ffor t $ \t -> do
-        (Process { _process_stdout = out }) <- createProcess (P.proc "date" []) never
+      out <- fixed 2 $ fmap (switch . current) $ networkHold (return never) $ ffor t $ \tick -> do
+        Process { _process_stdout = out } <- createProcess (P.proc "date" []) never
         row $ do
           fixed 10 $ text $ pure "Tick:"
-          stretch $ display $ pure t
+          stretch $ display $ pure tick
         return out
       fixed 2 $ do
         row $ do
           fixed 10 $ text "stdout:"
           stretch $ text <=< hold "" $ T.decodeUtf8 <$> out
-
     stretch $ boxStatic def $ col $ do
       fixed 3 $ text "Running interactive command. You'll be prompted to remove an empty file that this program has created."
       let tmpfile = fp <> "/my-temporary-file"
-      (Process { _process_exit = touchExit }) <- fixed 1 $ do
+      Process { _process_exit = touchExit } <- fixed 1 $ do
         text $ pure $ "$> touch " <> T.pack tmpfile
         createProcess (P.proc "touch" [tmpfile]) never
       fixed 1 $ text <=< hold "" $ "File created." <$ touchExit
       fixed 1 $ text $ pure $ "$> rm -i " <> T.pack tmpfile
       rec pout <- fixed 3 $ do
-            pout <- createProcess (P.proc "rm" ["-i", fp <> "/my-temporary-file"]) userInput
+            p <- createProcess (P.proc "rm" ["-i", fp <> "/my-temporary-file"]) userInput
             col $ do
               _ <- fixed 1 $ prefix "stdout:" $
-                text <=< hold "<no stdout yet>" $ T.decodeUtf8 <$> _process_stdout pout
+                text <=< hold "<no stdout yet>" $ T.decodeUtf8 <$> _process_stdout p
               _ <- fixed 1 $ prefix "stderr:" $
-                text <=< hold "<no stderr yet>" $ T.decodeUtf8 <$> _process_stderr pout
+                text <=< hold "<no stderr yet>" $ T.decodeUtf8 <$> _process_stderr p
               _ <- fixed 1 $ prefix "exit code:" $
-                display =<< hold Nothing (Just <$> _process_exit pout)
+                display =<< hold Nothing (Just <$> _process_exit p)
               return pout
           (i, enter) <- fixed 3 $ do
-            i <- boxStatic def $ prefix "Your response:" $ textInput def
-            enter <- key V.KEnter
-            return (i, enter)
-          let userInput = fmap T.encodeUtf8 $ tag (current (_textInput_value i)) enter
+            inp <- boxStatic def $ prefix "Your response:" $ textInput def
+            enterKeypress <- key V.KEnter
+            return (inp, enterKeypress)
+          let userInput = T.encodeUtf8 <$> tag (current $ _textInput_value i) enter
       fixed 1 $ prefix "exit code:" $
         display <=< hold Nothing $ Just <$> _process_exit pout
       fixed 1 $ prefix "enter pressed:" $
         display <=< hold Nothing $ Just <$> enter
       fixed 1 $ prefix "user input:" $
         display <=< hold Nothing $ Just <$> userInput
+      fixed 1 $ do
+        pb <- getPostBuild
+        watch <- watchDirectory (FS.defaultConfig { FS.confDebounce = FS.NoDebounce }) (fp <$ pb)
+        display <=< hold "" $ T.pack . show <$> watch
   return $ () <$ exit
   where
     prefix t a = row $ do
       fixed (pure $ T.length t + 1) $ text $ pure t
       stretch a
+
+watchDirectory
+  :: (Reflex t, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m))
+  => FS.WatchConfig
+  -> Event t FilePath
+  -> m (Event t FS.Event)
+watchDirectory cfg path =
+  performEventAsync $ ffor path $ \p cb -> liftIO $ void $ forkIO $
+    FS.withManagerConf cfg $ \mgr -> do
+      void $ FS.watchTree mgr p (const True) cb
+      forever $ threadDelay 1000000