Remove "Ok, modules loaded: .." message

cabal.project

@@ -1,7 +1,7 @@
 packages:
   sensei.cabal
 
-package sensei
+program-options
   ghc-options: -Werror
 
 tests: True

src/HTTP.hs

@@ -11,7 +11,7 @@ module HTTP (
 #endif
 ) where
 
-import           Imports
+import           Imports hiding (encodeUtf8)
 
 import           System.Directory
 import qualified Data.ByteString.Lazy as L

src/Imports.hs

@@ -26,6 +26,9 @@ import           Control.Monad.IO.Class as Imports
 import           System.IO (Handle)
 import           GHC.IO.Handle.Internals (wantReadableHandle_)
 
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
 pass :: Applicative m => m ()
 pass = pure ()
 
@@ -46,3 +49,9 @@ createPipe :: IO (Handle, Handle)
 #error Use `associateHandle'` as per https://hackage.haskell.org/package/process-1.6.17.0/docs/System-Process.html#v:createPipe
 #endif
 createPipe = Process.createPipe
+
+encodeUtf8 :: String -> ByteString
+encodeUtf8 = T.encodeUtf8 . T.pack
+
+decodeUtf8 :: ByteString -> String
+decodeUtf8 = T.unpack . T.decodeUtf8

src/Language/Haskell/GhciWrapper.hs

@@ -1,17 +1,27 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BlockArguments #-}
 module Language.Haskell.GhciWrapper (
   Config(..)
 , Interpreter(echo)
 , withInterpreter
 , eval
+
+, Extract(..)
+, partialMessageStartsWithOneOf
 , evalVerbose
+
+, ReloadStatus(..)
+, reload
+
+#ifdef TEST
+, extractReloadStatus
+, extractNothing
+#endif
 ) where
 
 import           Imports
 
 import qualified Data.ByteString as ByteString
-import           Data.Text.Encoding (decodeUtf8)
-import qualified Data.Text as T
 import           System.IO hiding (stdin, stdout, stderr)
 import           System.IO.Temp (withSystemTempFile)
 import           System.Environment (getEnvironment)
@@ -20,7 +30,7 @@ import           System.Exit (exitFailure)
 
 import           Util (isWritableByOthers)
 import qualified ReadHandle
-import           ReadHandle (ReadHandle, toReadHandle)
+import           ReadHandle (ReadHandle, toReadHandle, Extract(..), partialMessageStartsWithOneOf)
 
 data Config = Config {
   configIgnoreDotGhci :: Bool
@@ -123,13 +133,13 @@ new startupFile Config{..} envDefaults args_ = do
       hSetBuffering h LineBuffering
       hSetEncoding h utf8
 
-    printStartupMessages :: Interpreter -> IO String
-    printStartupMessages interpreter = evalVerbose interpreter ""
+    printStartupMessages :: Interpreter -> IO (String, [ReloadStatus])
+    printStartupMessages interpreter = evalVerbose extractReloadStatus interpreter ""
 
 close :: Interpreter -> IO ()
 close Interpreter{..} = do
   hClose hIn
-  ReadHandle.drain readHandle echo
+  ReadHandle.drain extractNothing readHandle echo
   hClose hOut
   e <- waitForProcess process
   when (e /= ExitSuccess) $ do
@@ -141,14 +151,39 @@ putExpression Interpreter{hIn = stdin} e = do
   ByteString.hPut stdin ReadHandle.marker
   hFlush stdin
 
-getResult :: Interpreter -> IO String
-getResult Interpreter{..} = T.unpack . decodeUtf8 <$> ReadHandle.getResult readHandle echo
+data ReloadStatus = Ok | Failed
+  deriving (Eq, Show)
+
+extractReloadStatus :: Extract ReloadStatus
+extractReloadStatus = Extract {
+  isPartialMessage = partialMessageStartsWithOneOf [ok, failed]
+, parseMessage = \ case
+    line | ByteString.isPrefixOf ok line -> Just (Ok, "")
+    line | ByteString.isPrefixOf failed line -> Just (Failed, "")
+    _ -> Nothing
+} where
+    ok = "Ok, modules loaded: "
+    failed = "Failed, modules loaded: "
+
+extractNothing :: Extract ()
+extractNothing = Extract {
+  isPartialMessage = const False
+, parseMessage = undefined
+}
+
+getResult :: Extract a -> Interpreter -> IO (String, [a])
+getResult extract Interpreter{..} = first decodeUtf8 <$> ReadHandle.getResult extract readHandle echo
 
 silent :: ByteString -> IO ()
 silent _ = pass
 
 eval :: Interpreter -> String -> IO String
-eval ghci = evalVerbose ghci {echo = silent}
+eval ghci = fmap fst . evalVerbose extractNothing ghci {echo = silent}
+
+evalVerbose :: Extract a -> Interpreter -> String -> IO (String, [a])
+evalVerbose extract ghci expr = putExpression ghci expr >> getResult extract ghci
 
-evalVerbose :: Interpreter -> String -> IO String
-evalVerbose ghci expr = putExpression ghci expr >> getResult ghci
+reload :: Interpreter -> IO (String, ReloadStatus)
+reload ghci = evalVerbose extractReloadStatus ghci ":reload" <&> second \ case
+  [Ok] -> Ok
+  _ -> Failed

src/ReadHandle.hs

@@ -3,9 +3,13 @@ module ReadHandle (
   ReadHandle(..)
 , toReadHandle
 , marker
+, Extract(..)
+, partialMessageStartsWith
+, partialMessageStartsWithOneOf
 , getResult
 , drain
 #ifdef TEST
+, breakAfterNewLine
 , newEmptyBuffer
 #endif
 ) where
@@ -34,9 +38,9 @@ data ReadHandle = ReadHandle {
 , buffer :: IORef Buffer
 }
 
-drain :: ReadHandle -> (ByteString -> IO ()) -> IO ()
-drain h echo = while (not <$> isEOF h) $ do
-  _ <- getResult h echo
+drain :: Extract a -> ReadHandle -> (ByteString -> IO ()) -> IO ()
+drain extract h echo = while (not <$> isEOF h) $ do
+  _ <- getResult extract h echo
   pass
 
 isEOF :: ReadHandle -> IO Bool
@@ -73,15 +77,64 @@ toReadHandle h n = do
 newEmptyBuffer :: IO (IORef Buffer)
 newEmptyBuffer = newIORef BufferEmpty
 
-getResult :: ReadHandle -> (ByteString -> IO ()) -> IO ByteString
-getResult h echo = mconcat <$> go
-  where
-    go :: IO [ByteString]
-    go = nextChunk h >>= \ case
-      Chunk chunk -> echo chunk >> (chunk :) <$> go
+data Extract a = Extract {
+  isPartialMessage :: ByteString -> Bool
+, parseMessage :: ByteString -> Maybe (a, ByteString)
+}
+
+partialMessageStartsWith :: ByteString -> ByteString -> Bool
+partialMessageStartsWith prefix chunk = ByteString.isPrefixOf chunk prefix || ByteString.isPrefixOf prefix chunk
+
+partialMessageStartsWithOneOf :: [ByteString] -> ByteString -> Bool
+partialMessageStartsWithOneOf xs x = any ($ x) $ map partialMessageStartsWith xs
+
+getResult :: Extract a -> ReadHandle -> (ByteString -> IO ()) -> IO (ByteString, [a])
+getResult extract h echo = do
+  ref <- newIORef []
+
+  let
+    startOfLine :: ByteString -> IO [ByteString]
+    startOfLine = \ case
+      "" -> withMoreInput_ startOfLine
+      chunk | extract.isPartialMessage chunk -> extractMessage chunk
+      chunk -> notStartOfLine chunk
+
+    notStartOfLine :: ByteString -> IO [ByteString]
+    notStartOfLine chunk = case breakAfterNewLine chunk of
+      Nothing -> echo chunk >> (chunk :) <$> withMoreInput_ notStartOfLine
+      Just (x, xs) -> echo x >> (x :) <$> startOfLine xs
+
+    extractMessage :: ByteString -> IO [ByteString]
+    extractMessage chunk = case breakAfterNewLine chunk of
+      Nothing -> withMoreInput chunk startOfLine
+      Just (x, xs) -> do
+        c <- case extract.parseMessage x of
+          Nothing -> do
+            return x
+          Just (message, formatted) -> do
+            modifyIORef' ref (message :)
+            return formatted
+        echo c >> (c :) <$> startOfLine xs
+
+    withMoreInput_ :: (ByteString -> IO [ByteString]) -> IO [ByteString]
+    withMoreInput_ action = nextChunk h >>= \ case
+      Chunk chunk -> action chunk
       Marker -> return []
       EOF -> return []
 
+    withMoreInput :: ByteString -> (ByteString -> IO [ByteString]) -> IO [ByteString]
+    withMoreInput acc action = nextChunk h >>= \ case
+      Chunk chunk -> action (acc <> chunk)
+      Marker -> echo acc >> return [acc]
+      EOF -> echo acc >> return [acc]
+
+  (,) <$> (mconcat <$> withMoreInput_ startOfLine) <*> readIORef ref
+
+breakAfterNewLine :: ByteString -> Maybe (ByteString, ByteString)
+breakAfterNewLine input = case ByteString.elemIndex '\n' input of
+  Just n -> Just (ByteString.splitAt (n + 1) input)
+  Nothing -> Nothing
+
 data Chunk = Chunk ByteString | Marker | EOF
 
 nextChunk :: ReadHandle -> IO Chunk

src/Session.hs

@@ -4,6 +4,8 @@ module Session (
 , Session(..)
 , echo
 , withSession
+
+, ReloadStatus(..)
 , reload
 
 , Summary(..)
@@ -18,15 +20,17 @@ module Session (
 , hasSpec
 , hasHspecCommandSignature
 , hspecCommand
-, parseSummary
+, extractSummary
 #endif
 ) where
 
 import           Imports
 
 import           Data.IORef
+import qualified Data.ByteString as ByteString
 
-import           Language.Haskell.GhciWrapper
+import           Language.Haskell.GhciWrapper hiding (reload)
+import qualified Language.Haskell.GhciWrapper as Interpreter
 
 import           Util
 import           Options
@@ -57,8 +61,8 @@ withSession config args action = do
   where
     (ghciArgs, hspecArgs) = splitArgs args
 
-reload :: MonadIO m => Session -> m String
-reload session = liftIO $ evalVerbose session.interpreter ":reload"
+reload :: MonadIO m => Session -> m (String, ReloadStatus)
+reload session = liftIO $ Interpreter.reload session.interpreter
 
 data Summary = Summary {
   summaryExamples :: Int
@@ -103,8 +107,8 @@ runSpec :: String -> Session -> IO String
 runSpec command session = do
   failedPreviously <- isFailure <$> hspecPreviousSummary session
   let args = "--color" : (if failedPreviously then addRerun else id) session.hspecArgs
-  r <- evalVerbose session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command
-  writeIORef session.hspecPreviousSummaryRef (parseSummary r)
+  (r, summary) <- evalVerbose extractSummary session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command
+  writeIORef session.hspecPreviousSummaryRef . listToMaybe $ reverse summary
   return r
   where
     addRerun :: [String] -> [String]
@@ -116,13 +120,19 @@ isFailure = maybe True ((/= 0) . (.summaryFailures))
 isSuccess :: Maybe Summary -> Bool
 isSuccess = not . isFailure
 
-parseSummary :: String -> Maybe Summary
-parseSummary = findJust . map (readMaybe . dropAnsiEscapeSequences) . reverse . lines
-  where
-    findJust = listToMaybe . catMaybes
+extractSummary :: Extract Summary
+extractSummary = Extract {
+  isPartialMessage = partialMessageStartsWithOneOf [summaryPrefix, ansiShowCursor <> summaryPrefix]
+, parseMessage = fmap (flip (,) "") . parseSummary
+} where
+    summaryPrefix :: ByteString
+    summaryPrefix = "Summary {"
+
+    parseSummary :: ByteString -> Maybe Summary
+    parseSummary = readMaybe . decodeUtf8 . stripAnsiShowCursor
+
+    ansiShowCursor :: ByteString
+    ansiShowCursor = "\ESC[?25h"
 
-    dropAnsiEscapeSequences xs
-      | "Summary" `isPrefixOf` xs = xs
-      | otherwise = case xs of
-          _ : ys -> dropAnsiEscapeSequences ys
-          [] -> []
+    stripAnsiShowCursor :: ByteString -> ByteString
+    stripAnsiShowCursor input = fromMaybe input $ ByteString.stripPrefix ansiShowCursor input

src/Trigger.hs

@@ -25,7 +25,7 @@ import           Control.Monad.Except
 
 import           Util
 import           Config (Hook, HookResult(..))
-import           Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary)
+import           Session (Session, ReloadStatus(..), isFailure, isSuccess, hspecPreviousSummary, resetSummary)
 import qualified Session
 
 data Hooks = Hooks {
@@ -47,12 +47,6 @@ triggerAll session hooks = do
   resetSummary session
   trigger session hooks
 
-reloadedSuccessfully :: String -> Bool
-reloadedSuccessfully = any success . lines
-  where
-    success :: String -> Bool
-    success = isPrefixOf "Ok, modules loaded: "
-
 removeProgress :: String -> String
 removeProgress xs = case break (== '\r') xs of
   (_, "") -> xs
@@ -71,13 +65,13 @@ trigger session hooks = runWriterT (runExceptT go) >>= \ case
     go :: Trigger ()
     go = do
       runHook hooks.beforeReload
-      output <- Session.reload session
+      (output, r) <- Session.reload session
       tell output
-      case reloadedSuccessfully output of
-        False -> do
+      case r of
+        Failed -> do
           echo $ withColor Red "RELOADING FAILED" <> "\n"
           abort
-        True -> do
+        Ok -> do
           echo $ withColor Green "RELOADING SUCCEEDED" <> "\n"
 
       runHook hooks.afterReload

src/Util.hs

@@ -3,7 +3,6 @@ module Util (
   Color(..)
 , withColor
 , withInfoColor
-, encodeUtf8
 , isBoring
 , filterGitIgnoredFiles
 , normalizeTypeSignatures
@@ -23,7 +22,6 @@ import           System.Process
 import           System.Posix.Files
 import           System.Posix.Types
 import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
 
 withInfoColor :: String -> String
 withInfoColor = withColor Magenta
@@ -34,9 +32,6 @@ withColor c string =  set <> string <> reset
     set = setSGRCode [SetColor Foreground Dull c]
     reset = setSGRCode []
 
-encodeUtf8 :: String -> ByteString
-encodeUtf8 = T.encodeUtf8 . T.pack
-
 isBoring :: FilePath -> Bool
 isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p
   where