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,10 +1,19 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BlockArguments #-}
 module Language.Haskell.GhciWrapper (
   Config(..)
 , Interpreter(echo)
 , withInterpreter
 , eval
 , evalVerbose
+, evalVerbose_
+
+, ReloadingSucceeded(..)
+, reload
+
+#ifdef TEST
+, extractDiagnostics
+#endif
 ) where
 
 import           Imports
@@ -20,7 +29,7 @@ import           System.Exit (exitFailure)
 
 import           Util (isWritableByOthers)
 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 -> IO (String, [ReloadingSucceeded])
     printStartupMessages interpreter = evalVerbose 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,52 @@ 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 ReloadingSucceeded = ReloadingFailed | ReloadingSucceeded
+  deriving (Eq, Show)
+
+extractDiagnostics :: Extract ReloadingSucceeded
+extractDiagnostics = 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 (ReloadingSucceeded, "")
+      line | ByteString.isPrefixOf failed line -> Just (ReloadingFailed, "")
+      _ -> Nothing
+  }
+  where
+
+    ok = "Ok, modules loaded: "
+    failed = "Failed, modules loaded: "
+
+extractNothing :: Extract ()
+extractNothing = Extract {
+  isPartialMessage = const False
+, parseMessage = undefined
+}
+
+getResult :: Interpreter -> IO (String, [ReloadingSucceeded])
+getResult Interpreter{..} = first (T.unpack . decodeUtf8) <$> ReadHandle.getResult extractDiagnostics readHandle echo
+
+getResult_ :: Extract a -> Interpreter -> IO (String, [a])
+getResult_ extract Interpreter{..} = first (T.unpack . 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 ghci {echo = silent}
 
-evalVerbose :: Interpreter -> String -> IO String
+evalVerbose :: Interpreter -> String -> IO (String, [ReloadingSucceeded])
 evalVerbose ghci expr = putExpression ghci expr >> getResult ghci
+
+evalVerbose_ :: Extract a -> Interpreter -> String -> IO (String, [a])
+evalVerbose_ extract ghci expr = putExpression ghci expr >> getResult_ extract ghci
+
+reload :: Interpreter -> IO (String, ReloadingSucceeded)
+reload ghci = evalVerbose_ extractDiagnostics ghci ":reload" <&> second \ case
+  [ReloadingSucceeded] -> ReloadingSucceeded
+  _ -> ReloadingFailed

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 = goJson 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
+
+    goJson :: ByteString -> IO [ByteString]
+    goJson chunk = case breakAfterNewLine chunk of
+      Nothing -> withMoreInput chunk goJson
+      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
+
+, ReloadingSucceeded(..)
 , reload
 
 , Summary(..)
@@ -26,7 +28,8 @@ 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
@@ -57,8 +60,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, ReloadingSucceeded)
+reload session = liftIO $ Interpreter.reload session.interpreter
 
 data Summary = Summary {
   summaryExamples :: Int
@@ -103,7 +106,7 @@ 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
+  (r, _) <- evalVerbose session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command
   writeIORef session.hspecPreviousSummaryRef (parseSummary r)
   return r
   where

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, ReloadingSucceeded(..), 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
+        ReloadingFailed -> do
           echo $ withColor Red "RELOADING FAILED" <> "\n"
           abort
-        True -> do
+        ReloadingSucceeded -> do
           echo $ withColor Green "RELOADING SUCCEEDED" <> "\n"
 
       runHook hooks.afterReload

test/Helper.hs

@@ -96,7 +96,7 @@ failingSpec = unlines [
 data Status = Ok | Failed
   deriving (Eq, Show)
 
-modulesLoaded :: Status -> [String] -> String
+modulesLoaded :: Status -> [String] -> String -- FIXME: remove
 modulesLoaded status xs = show status ++ ", modules loaded: " <> mods <> "."
   where
     mods = case xs of

test/Language/Haskell/GhciWrapperSpec.hs

@@ -4,7 +4,7 @@ module Language.Haskell.GhciWrapperSpec (main, spec) where
 import           Helper
 import qualified Data.ByteString.Char8 as ByteString
 
-import           Language.Haskell.GhciWrapper (Config(..), Interpreter(..))
+import           Language.Haskell.GhciWrapper (Config(..), Interpreter(..), ReloadingSucceeded(..))
 import qualified Language.Haskell.GhciWrapper as Interpreter
 
 main :: IO ()
@@ -55,7 +55,7 @@ spec = do
     it "echos result" $ do
       fmap mconcat . withSpy $ \ spy -> do
         withInterpreter [] $ \ ghci -> do
-          Interpreter.evalVerbose ghci {echo = spy} "23" `shouldReturn` "23\n"
+          Interpreter.evalVerbose ghci {echo = spy} "23" `shouldReturn` ("23\n", [])
       `shouldReturn` "23\n"
 
   describe "eval" $ do
@@ -116,9 +116,37 @@ spec = do
       ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n"
 
     it "gives an error message for identifiers that are not in scope" $ withGhci $ \ ghci -> do
-      ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo")
+      ghci "foo" >>= (`shouldContain` "Variable not in scope: foo")
 
     context "with -XNoImplicitPrelude" $ do
       it "works" $ withInterpreter ["-XNoImplicitPrelude"] $ \ ghci -> do
         Interpreter.eval ghci "putStrLn \"foo\"" >>= (`shouldContain` "Variable not in scope: putStrLn")
         Interpreter.eval ghci "23" `shouldReturn` "23\n"
+
+  describe "reload" $ do
+    it "reloads" $ do
+      withTempDirectory $ \ dir -> do
+        let
+          name :: FilePath
+          name = dir </> "Foo.hs"
+
+        writeFile name $ unlines [
+            "module Foo where"
+          ]
+
+        withInterpreter [name] $ \ ghci -> do
+          Interpreter.reload ghci `shouldReturn` ("", ReloadingSucceeded)
+
+    it "reloads" $ do
+      withTempDirectory $ \ dir -> do
+        let
+          name :: FilePath
+          name = dir </> "Foo.hs"
+
+        writeFile name $ unlines [
+            "module Foo where"
+          , "foo = bar"
+          ]
+
+        withInterpreter [name] $ \ ghci -> do
+          snd <$> Interpreter.reload ghci `shouldReturn` ReloadingFailed