packages feed

sensei 0.6.2 → 0.7.0

raw patch · 16 files changed

+646/−209 lines, 16 filesdep +QuickCheckdep +hspec-contribdep ~fsnotify

Dependencies added: QuickCheck, hspec-contrib

Dependency ranges changed: fsnotify

Files

− doctest/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Language.Haskell.GhciWrapper (-  Interpreter-, Config(..)-, defaultConfig-, new-, close-, eval-, evalIt-, evalEcho-) where--import           System.IO hiding (stdin, stdout, stderr)-import           System.Process-import           System.Exit-import           Control.Monad-import           Control.Exception-import           Data.List (isSuffixOf)-import           Data.Maybe--data Config = Config {-  configGhci :: String-, configVerbose :: Bool-, configIgnoreDotGhci :: Bool-} deriving (Eq, Show)--defaultConfig :: Config-defaultConfig = Config {-  configGhci = "ghci"-, configVerbose = False-, configIgnoreDotGhci = True-}---- | Truly random marker, used to separate expressions.------ IMPORTANT: This module relies upon the fact that this marker is unique.  It--- has been obtained from random.org.  Do not expect this module to work--- properly, if you reuse it for any purpose!-marker :: String-marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"--itMarker :: String-itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"--data Interpreter = Interpreter {-    hIn  :: Handle-  , hOut :: Handle-  , process :: ProcessHandle-  }--new :: Config -> [String] -> IO Interpreter-new Config{..} args_ = do-  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}-  setMode stdin_-  setMode stdout_-  let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}-  _ <- eval interpreter "import qualified System.IO"-  _ <- eval interpreter "import qualified GHC.IO.Handle"-  -- The buffering of stdout and stderr is NoBuffering-  _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"-  -- Now the buffering of stderr is BlockBuffering Nothing-  -- In this situation, GHC 7.7 does not flush the buffer even when-  -- error happens.-  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"-  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"--  -- this is required on systems that don't use utf8 as default encoding (e.g.-  -- Windows)-  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Handle.utf8"-  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Handle.utf8"--  _ <- eval interpreter ":m - System.IO"-  _ <- eval interpreter ":m - GHC.IO.Handle"--  return interpreter-  where-    args = args_ ++ catMaybes [-        if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing-      , if configVerbose then Nothing else Just "-v0"-      ]-    setMode h = do-      hSetBinaryMode h False-      hSetBuffering h LineBuffering-      hSetEncoding h utf8--close :: Interpreter -> IO ()-close repl = do-  hClose $ hIn repl--  -- It is crucial not to close `hOut` before calling `waitForProcess`,-  -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang-  -- around consuming 100% CPU.  This happens when ghci tries to print-  -- something to stdout in its signal handler (e.g. when it is blocked in-  -- threadDelay it writes "Interrupted." on SIGINT).-  e <- waitForProcess $ process repl-  hClose $ hOut repl--  when (e /= ExitSuccess) $ do-    throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")--putExpression :: Interpreter -> Bool -> String -> IO ()-putExpression Interpreter{hIn = stdin} preserveIt e = do-  hPutStrLn stdin e-  when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it"-  hPutStrLn stdin (marker ++ " :: Data.String.String")-  when preserveIt $ hPutStrLn stdin $ "let it = " ++ itMarker-  hFlush stdin--getResult :: Bool -> Interpreter -> IO String-getResult echoMode Interpreter{hOut = stdout} = go-  where-    go = do-      line <- hGetLine stdout-      if marker `isSuffixOf` line-        then do-          let xs = stripMarker line-          echo xs-          return xs-        else do-          echo (line ++ "\n")-          result <- go-          return (line ++ "\n" ++ result)-    stripMarker l = take (length l - length marker) l--    echo :: String -> IO ()-    echo-      | echoMode = putStr-      | otherwise = (const $ return ())---- | Evaluate an expression-eval :: Interpreter -> String -> IO String-eval repl expr = do-  putExpression repl False expr-  getResult False repl---- | Like 'eval', but try to preserve the @it@ variable-evalIt :: Interpreter -> String -> IO String-evalIt repl expr = do-  putExpression repl True expr-  getResult False repl---- | Evaluate an expression-evalEcho :: Interpreter -> String -> IO String-evalEcho repl expr = do-  putExpression repl False expr-  getResult True repl
driver/sensei-web.hs view
@@ -2,7 +2,10 @@  import           System.Environment +import           Paths_sensei import           Run  main :: IO ()-main = getArgs >>= runWeb+main = do+  startupFile <- getDataFileName "startup.ghci"+  getArgs >>= runWeb startupFile
driver/sensei.hs view
@@ -2,7 +2,10 @@  import           System.Environment +import           Paths_sensei import           Run  main :: IO ()-main = getArgs >>= run+main = do+  startupFile <- getDataFileName "startup.ghci"+  getArgs >>= run startupFile
sensei.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack  name:           sensei-version:        0.6.2+version:        0.7.0 synopsis:       Automatically run Hspec tests on file modifications category:       Development homepage:       https://github.com/hspec/sensei#readme@@ -14,6 +14,8 @@ license:        MIT license-file:   LICENSE build-type:     Simple+data-files:+    startup.ghci  source-repository head   type: git@@ -23,7 +25,6 @@   main-is: seito.hs   hs-source-dirs:       src-      doctest/ghci-wrapper/src/       driver   ghc-options: -Wall   build-depends:@@ -32,7 +33,7 @@     , bytestring     , directory     , filepath-    , fsnotify+    , fsnotify ==0.4.*     , http-client >=0.5.0     , http-types     , network@@ -48,12 +49,13 @@       EventQueue       HTTP       Imports+      Language.Haskell.GhciWrapper       Options+      ReadHandle       Run       Session       Trigger       Util-      Language.Haskell.GhciWrapper       Paths_sensei   default-language: Haskell2010 @@ -61,7 +63,6 @@   main-is: sensei.hs   hs-source-dirs:       src-      doctest/ghci-wrapper/src/       driver   ghc-options: -Wall   build-depends:@@ -70,7 +71,7 @@     , bytestring     , directory     , filepath-    , fsnotify+    , fsnotify ==0.4.*     , http-client >=0.5.0     , http-types     , network@@ -86,12 +87,13 @@       EventQueue       HTTP       Imports+      Language.Haskell.GhciWrapper       Options+      ReadHandle       Run       Session       Trigger       Util-      Language.Haskell.GhciWrapper       Paths_sensei   default-language: Haskell2010 @@ -99,7 +101,6 @@   main-is: sensei-web.hs   hs-source-dirs:       src-      doctest/ghci-wrapper/src/       driver   ghc-options: -Wall   build-depends:@@ -108,7 +109,7 @@     , bytestring     , directory     , filepath-    , fsnotify+    , fsnotify ==0.4.*     , http-client >=0.5.0     , http-types     , network@@ -124,12 +125,13 @@       EventQueue       HTTP       Imports+      Language.Haskell.GhciWrapper       Options+      ReadHandle       Run       Session       Trigger       Util-      Language.Haskell.GhciWrapper       Paths_sensei   default-language: Haskell2010 @@ -138,20 +140,21 @@   main-is: Spec.hs   hs-source-dirs:       src-      doctest/ghci-wrapper/src/       test   ghc-options: -Wall   cpp-options: -DTEST   build-tool-depends:       hspec-discover:hspec-discover   build-depends:-      ansi-terminal+      QuickCheck+    , ansi-terminal     , base >=4.11 && <5     , bytestring     , directory     , filepath-    , fsnotify+    , fsnotify ==0.4.*     , hspec >=2.9.0+    , hspec-contrib >=0.5.2     , hspec-wai     , http-client >=0.5.0     , http-types@@ -170,17 +173,20 @@       EventQueue       HTTP       Imports+      Language.Haskell.GhciWrapper       Options+      ReadHandle       Run       Session       Trigger       Util-      Language.Haskell.GhciWrapper       ClientSpec       EventQueueSpec       Helper       HTTPSpec+      Language.Haskell.GhciWrapperSpec       OptionsSpec+      ReadHandleSpec       SessionSpec       TriggerSpec       UtilSpec
src/Imports.hs view
@@ -1,14 +1,29 @@ module Imports (module Imports) where +import           Control.Arrow as Imports ((>>>), (&&&)) import           Control.Concurrent as Imports import           Control.Exception as Imports import           Control.Monad as Imports+import           Data.Functor as Imports import           Data.Bifunctor as Imports import           Data.Char as Imports import           Data.List as Imports import           Data.Maybe as Imports import           Data.String as Imports+import           Data.ByteString.Char8 as Imports (ByteString, pack, unpack) import           Data.Text.Lazy.Encoding as Imports (encodeUtf8) import           Data.Tuple as Imports import           System.IO.Error as Imports (isDoesNotExistError) import           Text.Read as Imports (readMaybe)++pass :: Applicative m => m ()+pass = pure ()++while :: Monad m => m Bool -> m () -> m ()+while p action = go+  where+    go = do+      notDone <- p+      when notDone $ do+        action+        go
+ src/Language/Haskell/GhciWrapper.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+module Language.Haskell.GhciWrapper (+  Config(..)+, Interpreter+, withInterpreter+, eval+, evalVerbose+) where++import           Imports++import qualified Data.ByteString as B+import           Data.Text.Encoding (decodeUtf8)+import qualified Data.Text as T+import           System.IO hiding (stdin, stdout, stderr)+import qualified System.IO as System+import           System.Directory (doesFileExist)+import           System.Process+import           System.Exit (ExitCode(..))++import qualified ReadHandle+import           ReadHandle (ReadHandle, toReadHandle)++data Config = Config {+  configIgnoreDotGhci :: Bool+, configVerbose :: Bool+, configStartupFile :: FilePath+} deriving (Eq, Show)++data Interpreter = Interpreter {+  hIn  :: Handle+, hOut :: Handle+, readHandle :: ReadHandle+, process :: ProcessHandle+}++die :: String -> IO a+die = throwIO . ErrorCall++withInterpreter :: Config -> [String] -> (Interpreter -> IO r) -> IO r+withInterpreter config args = bracket (new config args) (close $ verbosity config)++new :: Config -> [String] -> IO Interpreter+new config@Config{..} args_ = do++  requireFile configStartupFile++  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess (proc "ghci" args) {+    std_in  = CreatePipe+  , std_out = CreatePipe+  , std_err = Inherit+  }++  setMode stdin_+  readHandle <- toReadHandle stdout_ 1024++  let+    interpreter = Interpreter {+      hIn = stdin_+    , readHandle+    , hOut = stdout_+    , process = processHandle+    }++  _ <- printStartupMessages interpreter++  evalThrow interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"++  -- GHCi uses NoBuffering for stdout and stderr by default:+  -- https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/ghci.html+  evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"+  evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"++  evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8"+  evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8"++  return interpreter+  where+    requireFile name = do+      exists <- doesFileExist name+      unless exists $ do+        die $ "Required file " <> show name <> " does not exist!"++    args = "-ghci-script" : configStartupFile : args_ ++ catMaybes [+        if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing+      ]++    setMode h = do+      hSetBinaryMode h False+      hSetBuffering h LineBuffering+      hSetEncoding h utf8++    printStartupMessages interpreter = evalWith (verbosity config) interpreter ""++    evalThrow :: Interpreter -> String -> IO ()+    evalThrow interpreter expr = do+      output <- eval interpreter expr+      unless (null output) $ do+        close (verbosity config) interpreter+        die output++close :: (ByteString -> IO ()) -> Interpreter -> IO ()+close echo Interpreter{..} = do+  hClose hIn+  ReadHandle.drain readHandle echo+  hClose hOut+  e <- waitForProcess process+  when (e /= ExitSuccess) $ do+    throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")++putExpression :: Interpreter -> String -> IO ()+putExpression Interpreter{hIn = stdin} e = do+  hPutStrLn stdin e+  B.hPut stdin ReadHandle.marker+  hFlush stdin++getResult :: Interpreter -> (ByteString -> IO ()) -> IO String+getResult Interpreter{readHandle = h} = fmap (T.unpack . decodeUtf8) . ReadHandle.getResult h++verbosity :: Config -> ByteString -> IO ()+verbosity config+  | configVerbose config = verbose+  | otherwise = silent++verbose :: ByteString -> IO ()+verbose string = B.putStr string >> hFlush System.stdout++silent :: ByteString -> IO ()+silent _ = pass++evalWith :: (ByteString -> IO ()) -> Interpreter -> String -> IO String+evalWith echo repl expr = do+  putExpression repl expr+  getResult repl echo++eval :: Interpreter -> String -> IO String+eval = evalWith silent++evalVerbose :: Interpreter -> String -> IO String+evalVerbose = evalWith verbose
+ src/ReadHandle.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+module ReadHandle (+  ReadHandle(..)+, toReadHandle+, marker+, getResult+, drain+#ifdef TEST+, newEmptyBuffer+#endif+) where++import           Imports++import qualified Data.ByteString.Char8 as B+import           Data.IORef+import           System.IO hiding (stdin, stdout, stderr, isEOF)++#if MIN_VERSION_bytestring(0,11,0)+import           Data.ByteString (dropEnd)+#else+import qualified Data.ByteString.Internal as B+dropEnd :: Int -> ByteString -> ByteString+dropEnd n ps@(B.PS x offset len)+    | n <= 0    = ps+    | n >= len  = B.empty+    | otherwise = B.PS x offset (len - n)+#endif++-- | Truly random marker, used to separate expressions.+--+-- IMPORTANT: This module relies upon the fact that this marker is unique.  It+-- has been obtained from random.org.  Do not expect this module to work+-- properly, if you reuse it for any purpose!+marker :: ByteString+marker = pack (show @String "be77d2c8427d29cd1d62b7612d8e98cc") <> "\n"++partialMarkers :: [ByteString]+partialMarkers = reverse . drop 1 . init $ B.inits marker++data ReadHandle = ReadHandle {+  getChunk :: IO ByteString+, buffer :: IORef Buffer+}++drain :: ReadHandle -> (ByteString -> IO ()) -> IO ()+drain h echo = while (not <$> isEOF h) $ do+  _ <- getResult h echo+  pass++isEOF :: ReadHandle -> IO Bool+isEOF ReadHandle{..} = do+  readIORef buffer <&> \ case+    BufferEOF -> True+    BufferEmpty -> False+    BufferPartialMarker {}  -> False+    BufferChunk {} -> False++emptyBuffer :: Buffer -> Buffer+emptyBuffer old = case old of+  BufferEOF -> BufferEOF+  BufferEmpty -> BufferEmpty+  BufferPartialMarker {}  -> BufferEmpty+  BufferChunk {} -> BufferEmpty++mkBufferChunk :: ByteString -> Buffer+mkBufferChunk chunk+  | B.null chunk = BufferEmpty+  | otherwise = BufferChunk chunk++data Buffer =+    BufferEOF+  | BufferEmpty+  | BufferPartialMarker !ByteString+  | BufferChunk !ByteString++toReadHandle :: Handle -> Int -> IO ReadHandle+toReadHandle h n = do+  hSetBinaryMode h True+  ReadHandle (B.hGetSome h n) <$> newEmptyBuffer++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+      Marker -> return []+      EOF -> return []++data Chunk = Chunk ByteString | Marker | EOF++nextChunk :: ReadHandle -> IO Chunk+nextChunk ReadHandle {..} = go+  where+    takeBuffer :: IO Buffer+    takeBuffer = atomicModifyIORef' buffer (emptyBuffer &&& id)++    putBuffer :: Buffer -> IO ()+    putBuffer = writeIORef buffer++    putBuffer_ :: ByteString -> IO ()+    putBuffer_ = putBuffer . mkBufferChunk++    getSome :: IO (Maybe ByteString)+    getSome = do+      chunk <- getChunk+      if B.null chunk then do+        putBuffer BufferEOF+        return Nothing+      else do+        return (Just chunk)++    go :: IO Chunk+    go = takeBuffer >>= \ case+      BufferEOF -> return EOF+      BufferEmpty -> getSome >>= \ case+        Nothing -> return EOF+        Just chunk -> processChunk chunk+      BufferPartialMarker partialMarker -> getSome >>= \ case+        Nothing -> return (Chunk partialMarker)+        Just chunk -> processChunk (partialMarker <> chunk)+      BufferChunk chunk -> processChunk chunk++    processChunk :: ByteString -> IO Chunk+    processChunk chunk = case stripMarker chunk of+      StrippedMarker rest -> do+        putBuffer_ rest+        return Marker+      PrefixBeforeMarker prefix rest -> do+        putBuffer_ rest+        return (Chunk prefix)+      NoMarker -> case splitPartialMarker chunk of+        Just (prefix, partialMarker) -> do+          putBuffer (BufferPartialMarker partialMarker)+          if B.null prefix then do+            go+          else do+            return (Chunk prefix)+        Nothing -> return (Chunk chunk)++splitPartialMarker :: ByteString -> Maybe (ByteString, ByteString)+splitPartialMarker chunk = split <$> findPartialMarker chunk+  where+    split partialMarker = (dropEnd (B.length partialMarker) chunk, partialMarker)++findPartialMarker :: ByteString -> Maybe ByteString+findPartialMarker chunk = find (`B.isSuffixOf` chunk) partialMarkers++data StripMarker =+    NoMarker+  | PrefixBeforeMarker !ByteString !ByteString+  | StrippedMarker !ByteString++stripMarker :: ByteString -> StripMarker+stripMarker input = case brakeAtMarker input of+  (_, "") -> NoMarker+  ("", dropMarker -> ys) -> StrippedMarker ys+  (xs, ys) -> PrefixBeforeMarker xs ys+  where+    brakeAtMarker = B.breakSubstring marker+    dropMarker = B.drop (B.length marker)
src/Run.hs view
@@ -11,7 +11,7 @@  import qualified HTTP import qualified Session-import           Session (Session)+import           Session (Session, Config(..))  import           EventQueue import           Trigger@@ -22,19 +22,24 @@  watchFiles :: EventQueue -> IO () watchFiles queue = do-  watch $ emitEvent queue . \ case-    Added file _ _ -> FileEvent FileAdded file-    Removed file _ _ -> FileEvent FileRemoved file-    Modified file _ _ -> FileEvent FileModified file-    Unknown file _ _ -> FileEvent FileModified file+  watch $ \ case+    Added file _ _ -> emit $ FileEvent FileAdded file+    Modified file _ _ -> emit $ FileEvent FileModified file+    ModifiedAttributes _file _ _ -> pass+    Removed file _ _ -> emit $ FileEvent FileRemoved file+    WatchedDirectoryRemoved _file _ _ -> pass+    CloseWrite file _ _ -> emit $ FileEvent FileModified file+    Unknown file _ _ _ -> emit $ FileEvent FileModified file   where-    isInteresting = (&&) <$> not . eventIsDirectory <*> not . isBoring . eventPath+    emit = emitEvent queue      watch action = void . forkIO $ do       withManager $ \ manager -> do         _stopListening <- watchTree manager "." isInteresting action         waitForever-+      where+        isInteresting = (&&) <$> isFile <*> not . isBoring . eventPath+        isFile = eventIsDirectory >>> (== IsFile)  watchInput :: EventQueue -> IO () watchInput queue = void . forkIO $ do@@ -43,8 +48,8 @@     emitEvent queue TriggerAll   emitEvent queue Done -run :: [String] -> IO ()-run args = do+run :: FilePath -> [String] -> IO ()+run startupFile args = do   queue <- newQueue   watchFiles queue   watchInput queue@@ -55,7 +60,7 @@       saveOutput action = modifyMVar_ lastOutput $ \_ -> action        go = do-        status <- withSession args $ \ session -> do+        status <- withSession startupFile args $ \ session -> do           let             triggerAction = saveOutput (trigger session)             triggerAllAction = saveOutput (triggerAll session)@@ -66,16 +71,16 @@           Terminate -> return ()     go -runWeb :: [String] -> IO ()-runWeb args = do-  withSession args $ \session -> do+runWeb :: FilePath -> [String] -> IO ()+runWeb startupFile args = do+  withSession startupFile args $ \session -> do     _ <- trigger session     lock <- newMVar ()     HTTP.withServer (withMVar lock $ \() -> trigger session) $ do       waitForever -withSession :: [String] -> (Session -> IO a) -> IO a-withSession args action = do+withSession :: FilePath -> [String] -> (Session -> IO a) -> IO a+withSession startupFile args action = do   check <- dotGhciWritableByOthers   when check $ do     putStrLn ".ghci is writable by others, you can fix this with:"@@ -83,4 +88,11 @@     putStrLn "    chmod go-w .ghci ."     putStrLn ""     exitFailure-  bracket (Session.new args) Session.close action+  Session.withSession config args action+  where+    config :: Config+    config = Config {+      configIgnoreDotGhci = False+    , configVerbose = True+    , configStartupFile = startupFile+    }
src/Session.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Session (-  Session(..)-, new-, close+  Config(..)+, Session(..)+, withSession , reload  , Summary(..)@@ -27,8 +27,7 @@  import           Data.IORef -import qualified Language.Haskell.GhciWrapper as GhciWrapper-import           Language.Haskell.GhciWrapper hiding (new, close)+import           Language.Haskell.GhciWrapper  import           Util import           Options@@ -48,23 +47,17 @@ hspecPreviousSummary :: Session -> IO (Maybe Summary) hspecPreviousSummary Session{..} = readIORef sessionHspecPreviousSummary -new :: [String] -> IO Session-new args = do-  let (ghciArgs, hspecArgs) = splitArgs args-  ghci <- GhciWrapper.new defaultConfig{configVerbose = True, configIgnoreDotGhci = False} ghciArgs-  _ <- eval ghci (":set prompt " ++ show "")-  _ <- eval ghci ("import qualified System.Environment")-  _ <- eval ghci ("import qualified Test.Hspec.Runner")-  _ <- eval ghci ("import qualified Test.Hspec.Meta")-  _ <- eval ghci ("System.Environment.unsetEnv " ++ show hspecFailureEnvName)-  ref <- newIORef (Just $ Summary 0 0)-  return (Session ghci hspecArgs ref)--close :: Session -> IO ()-close = GhciWrapper.close . sessionInterpreter+withSession :: Config -> [String] -> (Session -> IO r) -> IO r+withSession config args action = do+  withInterpreter config ghciArgs $ \ ghci -> do+    _ <- eval ghci ("System.Environment.unsetEnv " ++ show hspecFailureEnvName)+    ref <- newIORef (Just $ Summary 0 0)+    action (Session ghci hspecArgs ref)+  where+    (ghciArgs, hspecArgs) = splitArgs args  reload :: Session -> IO String-reload Session{..} = evalEcho sessionInterpreter ":reload"+reload Session{..} = evalVerbose sessionInterpreter ":reload"  data Summary = Summary {   summaryExamples :: Int@@ -103,7 +96,7 @@ runSpec command session@Session{..} = do   failedPreviously <- isFailure <$> hspecPreviousSummary session   let args = "--color" : (if failedPreviously then addRerun else id) sessionHspecArgs-  r <- evalEcho sessionInterpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command+  r <- evalVerbose sessionInterpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command   writeIORef sessionHspecPreviousSummary (parseSummary r)   return r   where
src/Trigger.hs view
@@ -41,12 +41,14 @@       withColor Red $ putStrLn "RELOADING FAILED"       return (False, "")   where+    hspec :: IO (Bool, String)     hspec = do       mRun <- Session.getRunSpec session       case mRun of         Just run -> runSpecs run         Nothing -> return (True, "") +    runSpecs :: IO String -> IO (Bool, String)     runSpecs run = do       failedPreviously <- isFailure <$> hspecPreviousSummary session       (success, xs) <- runSpec run@@ -54,6 +56,7 @@         then runSpec run         else return (success, "") +    runSpec :: IO a -> IO (Bool, a)     runSpec run = do       xs <- run       success <- isSuccess <$> hspecPreviousSummary session
+ startup.ghci view
@@ -0,0 +1,4 @@+:set prompt ""+:unset +m +r +s +t +c+:seti -XHaskell2010+:seti -XNoOverloadedStrings
test/Helper.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE QuasiQuotes #-} module Helper (   module Imports+, ghciConfig , withSession , withSomeSpec , passingSpec@@ -16,16 +16,33 @@ import           System.Process as Imports (readProcess, callCommand) import           Test.Hspec as Imports import           Test.Mockery.Directory as Imports+import           Test.Hspec.Contrib.Mocks.V1 as Imports  import           Run () import qualified Session import           Session (Session)+import           Language.Haskell.GhciWrapper (Config(..)) +startupFile :: FilePath+startupFile = "startup.ghci"++ghciConfig :: Config+ghciConfig = Config {+  configIgnoreDotGhci = True+, configVerbose = False+, configStartupFile = startupFile+}+ withSession :: [String] -> (Session -> IO a) -> IO a-withSession args action = bracket (Session.new $ "-ignore-dot-ghci" : args) Session.close action+withSession = Session.withSession ghciConfig  withSomeSpec :: IO a -> IO a-withSomeSpec = (inTempDirectory .  (writeFile "Spec.hs" passingSpec >>))+withSomeSpec action = do+  startup <- readFile startupFile+  inTempDirectory $ do+    writeFile startupFile startup+    writeFile "Spec.hs" passingSpec+    action  passingSpec :: String passingSpec = unlines [
+ test/Language/Haskell/GhciWrapperSpec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+module Language.Haskell.GhciWrapperSpec (main, spec) where++import           Helper++import           Language.Haskell.GhciWrapper (Config(..), Interpreter)+import qualified Language.Haskell.GhciWrapper as Interpreter++main :: IO ()+main = hspec spec++withInterpreter :: [String] -> (Interpreter -> IO a) -> IO a+withInterpreter = Interpreter.withInterpreter ghciConfig++withGhci :: ((String -> IO String) -> IO a) -> IO a+withGhci action = withInterpreter [] $ action . Interpreter.eval++spec :: Spec+spec = do+  describe "withInterpreter" $ do+    context "on shutdown" $ do+      it "drains `stdout` of the `ghci` process" $ do+        result <- capture_ $ Interpreter.withInterpreter ghciConfig {configVerbose = True} [] $ \ _ghci -> do+          pass+        last (lines result) `shouldBe` "Leaving GHCi."++  describe "evalVerbose" $ do+    it "echos result to stdout" $ do+      withInterpreter [] $ \ ghci -> do+        capture (Interpreter.evalVerbose ghci $ "putStr" ++ show "foo\nbar") `shouldReturn` ("foo\nbar", "foo\nbar")++  describe "eval" $ do+    it "shows literals" $ withGhci $ \ ghci -> do+      ghci "23" `shouldReturn` "23\n"++    it "shows string literals containing Unicode" $ withGhci $ \ ghci -> do+      ghci "\"λ\"" `shouldReturn` "\"\\955\"\n"++    it "evaluates simple expressions" $ withGhci $ \ ghci -> do+      ghci "23 + 42" `shouldReturn` "65\n"++    it "uses LineBuffering for stdout and stderr" $ withGhci $ \ ghci -> do+      ghci "GHC.IO.Handle.hGetBuffering System.IO.stdout" `shouldReturn` "LineBuffering\n"+      ghci "GHC.IO.Handle.hGetBuffering System.IO.stderr" `shouldReturn` "LineBuffering\n"++    it "supports let bindings" $ withGhci $ \ ghci -> do+      ghci "let x = 10" `shouldReturn` ""+      ghci "x" `shouldReturn` "10\n"++    it "allows import statements" $ withGhci $ \ ghci -> do+      ghci "import Data.Maybe" `shouldReturn` ""+      ghci "fromJust (Just 20)" `shouldReturn` "20\n"++    it "captures stdout" $ withGhci $ \ ghci -> do+      ghci "putStr \"foo\"" `shouldReturn` "foo"++    it "captures stdout (Unicode)" $ withGhci $ \ ghci -> do+      ghci "putStrLn \"λ\"" `shouldReturn` "λ\n"++    it "captures stdout (empty line)" $ withGhci $ \ ghci -> do+      ghci "putStrLn \"\"" `shouldReturn` "\n"++    it "captures stdout (multiple lines)" $ withGhci $ \ ghci -> do+      ghci "putStrLn \"foo\" >> putStrLn \"bar\" >> putStrLn \"baz\""+        `shouldReturn` "foo\nbar\nbaz\n"++    it "captures stderr" $ withGhci $ \ ghci -> do+      ghci "import System.IO" `shouldReturn` ""+      ghci "hPutStrLn stderr \"foo\"" `shouldReturn` "foo\n"++    it "captures stderr (Unicode)" $ withGhci $ \ ghci -> do+      ghci "import System.IO" `shouldReturn` ""+      ghci "hPutStrLn stderr \"λ\"" `shouldReturn` "λ\n"++    it "shows exceptions" $ withGhci $ \ ghci -> do+      ghci "import Control.Exception" `shouldReturn` ""+      ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n"++    it "shows exceptions (ExitCode)" $ withGhci $ \ ghci -> do+      ghci "import System.Exit" `shouldReturn` ""+      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")++    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"
+ test/ReadHandleSpec.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module ReadHandleSpec (spec) where++import           Helper+import           Test.QuickCheck+import qualified Data.ByteString as B++import           ReadHandle++chunkByteString :: (Int, Int) -> ByteString -> Gen [ByteString]+chunkByteString size = go+  where+    go "" = return []+    go xs = do+      n <- chooseInt size+      let (chunk, rest) = B.splitAt n xs+      (chunk :) <$> go rest++fakeHandle :: [ByteString] -> IO ReadHandle+fakeHandle chunks = ReadHandle <$> stubAction chunks <*> newEmptyBuffer++data ChunkSizes = SmallChunks | BigChunks++withRandomChunkSizes :: [ByteString] -> (ReadHandle -> Expectation) -> Property+withRandomChunkSizes (mconcat -> input) action = property $ do+  chunkSizes <- elements [SmallChunks, BigChunks]+  let+    maxChunkSize = case chunkSizes of+      SmallChunks -> 4+      BigChunks -> B.length input++  chunks <- chunkByteString (1, maxChunkSize) input+  return $ fakeHandle chunks >>= action++partialMarker :: ByteString+partialMarker = B.take 5 marker++spec :: Spec+spec = do+  describe "drain" $ do+    it "drains all remaining input" $ do+      h <- fakeHandle ["foo", marker, "bar", marker, "baz", marker, ""]+      withSpy (drain h) `shouldReturn` ["foo", "bar", "baz"]++  describe "getResult" $ do+    context "with a single result" $ do+      let input = ["foo", "bar", "baz", marker]++      it "returns result" $ do+        withSpy $ \ echo -> do+          h <- fakeHandle input+          getResult h echo `shouldReturn` "foobarbaz"+        `shouldReturn` ["foo", "bar", "baz"]++      context "with chunks of arbitrary size" $ do+        it "returns result" $ do+          withRandomChunkSizes input $ \ h -> do+            fmap mconcat . withSpy $ \ echo -> do+              getResult h echo `shouldReturn` "foobarbaz"+            `shouldReturn` "foobarbaz"++    context "with multiple results" $ do+      let input = ["foo", marker, "bar", marker, "baz", marker]++      it "returns one result at a time" $ do+        withSpy $ \ echo -> do+          h <- fakeHandle input+          getResult h echo `shouldReturn` "foo"+          getResult h echo `shouldReturn` "bar"+          getResult h echo `shouldReturn` "baz"+        `shouldReturn` ["foo", "bar", "baz"]++      context "with chunks of arbitrary size" $ do+        it "returns one result at a time" $ do+          withRandomChunkSizes input $ \ h -> do+            fmap mconcat . withSpy $ \ echo -> do+              getResult h echo `shouldReturn` "foo"+              getResult h echo `shouldReturn` "bar"+              getResult h echo `shouldReturn` "baz"+            `shouldReturn` "foobarbaz"++    context "when a chunk that contains a marker ends with a partial marker" $ do+      it "correctly gives the marker precedence over the partial marker" $ do+        withSpy $ \ echo -> do+          h <- fakeHandle ["foo" <> marker <> "bar" <> partialMarker, ""]+          getResult h echo `shouldReturn` "foo"+          getResult h echo `shouldReturn` ("bar" <> partialMarker)+        `shouldReturn` ["foo", "bar", partialMarker]++    context "on EOF" $ do+      it "returns all remaining input" $ do+        withSpy $ \ echo -> do+          h <- fakeHandle ["foo", "bar", "baz", ""]+          getResult h echo `shouldReturn` "foobarbaz"+        `shouldReturn` ["foo", "bar", "baz"]++      context "with a partialMarker at the end" $ do+        it "includes the partial marker in the output" $ do+          withSpy $ \ echo -> do+            h <- fakeHandle ["foo", "bar", "baz", partialMarker, ""]+            getResult h echo `shouldReturn` ("foobarbaz" <> partialMarker)+          `shouldReturn` ["foo", "bar", "baz", partialMarker]++      context "after a marker" $ do+        it "returns all remaining input" $ do+          withSpy $ \ echo -> do+            h <- fakeHandle ["foo", "bar", "baz", marker, "qux", ""]+            getResult h echo `shouldReturn` "foobarbaz"+            getResult h echo `shouldReturn` "qux"+          `shouldReturn` ["foo", "bar", "baz", "qux"]
test/SessionSpec.hs view
@@ -7,16 +7,27 @@  import           Language.Haskell.GhciWrapper (eval) import qualified Session-import           Session (Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary, hspecCommand)+import           Session (Config(..), Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary, hspecCommand)  spec :: Spec spec = do-  describe "new" $ do+  describe "withSession" $ do     it "unsets HSPEC_FAILURES" $ do       setEnv hspecFailureEnvName "foo" True-      withSession [] $ \Session{..} -> do-        _ <- eval sessionInterpreter "import System.Environment"-        eval sessionInterpreter ("lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n"+      withSession [] $ \ Session{..} -> do+        eval sessionInterpreter ("System.Environment.lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n"++    context "with `:set +t +s`" $ do+      it "works just fine" $ do+        withSomeSpec $ do+          writeFile ".ghci" ":set +t +s"+          Session.withSession ghciConfig {configIgnoreDotGhci = False} [] $ \ Session{..} -> do+            eval sessionInterpreter "23" `shouldReturn` "23\n"++    context "with -XOverloadedStrings" $ do+      it "works just fine" $ do+        withSession ["-XOverloadedStrings", "-Wall", "-Werror"] $ \ Session{..} -> do+          eval sessionInterpreter "23 :: Int" `shouldReturn` "23\n"    describe "reload" $ do     it "reloads" $ do
test/TriggerSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module TriggerSpec (spec) where  import           Helper@@ -148,7 +149,11 @@           writeFile "Spec.hs" passingSpec           (True, xs) <- silence (trigger session)           normalize xs `shouldBe` [+#if __GLASGOW_HASKELL__ < 904               "[1 of 1] Compiling Spec             ( Spec.hs, interpreted )"+#else+              "[1 of 1] Compiling Spec             ( Spec.hs, interpreted ) [Source file changed]"+#endif             , modulesLoaded Ok ["Spec"]             , ""             , "bar [✔]"