Remove "Ok, modules loaded: .." message

cabal.project

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

src/Language/Haskell/GhciWrapper.hs

@@ -1,26 +1,35 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BlockArguments #-}
 module Language.Haskell.GhciWrapper (
   Config(..)
 , Interpreter(echo)
 , withInterpreter
 , eval
+
+, Extract(..)
 , 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)
 import           System.Process hiding (createPipe)
 import           System.Exit (exitFailure)
 
-import           Util (isWritableByOthers)
+import           Util (isWritableByOthers, decodeUtf8)
 import qualified ReadHandle
-import           ReadHandle (ReadHandle, toReadHandle)
+import           ReadHandle (ReadHandle, toReadHandle, Extract(..))
 
 data Config = Config {
   configIgnoreDotGhci :: Bool
@@ -123,13 +132,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 +150,45 @@ 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 = \ chunk -> or [
+        ByteString.isPrefixOf chunk ok
+      , ByteString.isPrefixOf ok chunk
+      , ByteString.isPrefixOf chunk failed
+      , ByteString.isPrefixOf failed chunk
+      ]
+  , 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,11 @@ module ReadHandle (
   ReadHandle(..)
 , toReadHandle
 , marker
+, Extract(..)
 , getResult
 , drain
 #ifdef TEST
+, breakAfterNewLine
 , newEmptyBuffer
 #endif
 ) where
@@ -34,9 +36,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 +75,58 @@ 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)
+}
+
+getResult :: Extract a -> ReadHandle -> (ByteString -> IO ()) -> IO (ByteString, [a])
+getResult extract h echo = do
+  ref <- newIORef []
+
+  let
+    startOfLine :: ByteString -> IO [ByteString]
+    startOfLine chunk
+      | extract.isPartialMessage chunk = extractMessage chunk
+      | otherwise = notStartOfLine chunk
+
+    notStartOfLine :: ByteString -> IO [ByteString]
+    notStartOfLine chunk = case breakAfterNewLine chunk of
+      Nothing -> echo chunk >> (chunk :) <$> withMoreInput_ notStartOfLine
+      Just (c, "") -> echo c >> (c :) <$> withMoreInput_ startOfLine
+      Just (c, xs) -> echo c >> (c :) <$> startOfLine xs
+
+    extractMessage :: ByteString -> IO [ByteString]
+    extractMessage chunk = case breakAfterNewLine chunk of
+      Nothing -> withMoreInput chunk startOfLine
+      Just (pre, suf) -> do
+        d <- case extract.parseMessage pre of
+          Nothing -> do
+            return pre
+          Just (diagnostic, formatted) -> do
+            modifyIORef' ref (diagnostic :)
+            return formatted
+        echo d >> (d :) <$> startOfLine suf
+
+    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,19 +20,22 @@ module Session (
 , hasSpec
 , hasHspecCommandSignature
 , hspecCommand
-, parseSummary
+, extractSummary
 #endif
 ) where
 
 import           Imports
 
 import           Data.IORef
 
-import           Language.Haskell.GhciWrapper
+import           Language.Haskell.GhciWrapper hiding (reload)
+import qualified Language.Haskell.GhciWrapper as Interpreter
 
 import           Util
 import           Options
 
+import qualified Data.ByteString as ByteString
+
 data Session = Session {
   interpreter :: Interpreter
 , hspecArgs :: [String]
@@ -57,14 +62,28 @@ 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
 , summaryFailures :: Int
 } deriving (Eq, Show, Read)
 
+extractSummary :: Extract Summary
+extractSummary = Extract {
+    isPartialMessage = \ chunk -> or [
+        ByteString.isPrefixOf chunk ok
+      , ByteString.isPrefixOf ok chunk
+      , ByteString.isPrefixOf chunk ok_
+      , ByteString.isPrefixOf ok_ chunk
+      ]
+  , parseMessage = fmap (flip (,) "") . parseSummary
+  }
+  where
+    ok = "Summary {"
+    ok_ = ansiShowCursor <> ok
+
 hspecCommand :: String
 hspecCommand = "Test.Hspec.Runner.hspecResult spec"
 
@@ -103,8 +122,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 summary
   return r
   where
     addRerun :: [String] -> [String]
@@ -116,13 +135,8 @@ 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
+parseSummary :: ByteString -> Maybe Summary
+parseSummary input = readMaybe . decodeUtf8 . fromMaybe input $ ByteString.stripPrefix ansiShowCursor input
 
-    dropAnsiEscapeSequences xs
-      | "Summary" `isPrefixOf` xs = xs
-      | otherwise = case xs of
-          _ : ys -> dropAnsiEscapeSequences ys
-          [] -> []
+ansiShowCursor :: ByteString
+ansiShowCursor = "\ESC[?25h"

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

@@ -4,6 +4,7 @@ module Util (
 , withColor
 , withInfoColor
 , encodeUtf8
+, decodeUtf8
 , isBoring
 , filterGitIgnoredFiles
 , normalizeTypeSignatures
@@ -37,6 +38,9 @@ withColor c string =  set <> string <> reset
 encodeUtf8 :: String -> ByteString
 encodeUtf8 = T.encodeUtf8 . T.pack
 
+decodeUtf8 :: ByteString -> String
+decodeUtf8 = T.unpack . T.decodeUtf8
+
 isBoring :: FilePath -> Bool
 isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p
   where

test/Helper.hs

@@ -8,8 +8,6 @@ module Helper (
 , passingSpec
 , passingMetaSpec
 , failingSpec
-, Status(..)
-, modulesLoaded
 
 , Color(..)
 , withColor
@@ -92,17 +90,3 @@ failingSpec = unlines [
   , "  it \"foo\" True"
   , "  it \"bar\" False"
   ]
-
-data Status = Ok | Failed
-  deriving (Eq, Show)
-
-modulesLoaded :: Status -> [String] -> String
-modulesLoaded status xs = show status ++ ", modules loaded: " <> mods <> "."
-  where
-    mods = case xs of
-      [] -> "none"
-      [name] -> formatModule name
-      _ -> undefined
-
-    formatModule :: String -> String
-    formatModule name = name <> " (" <> name <> ".o)"