packages feed

sensei (empty) → 0.0.0

raw patch · 23 files changed

+1246/−0 lines, 23 filesdep +ansi-terminaldep +basedep +base-compatsetup-changed

Dependencies added: ansi-terminal, base, base-compat, bytestring, directory, filepath, fsnotify, hspec, hspec-wai, http-client, http-types, interpolate, mockery, network, process, sensei, silently, stm, text, time, unix, wai, warp

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2015-2016 Simon Hengel <sol@typeful.net>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doctest/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RecordWildCards #-}+module Language.Haskell.GhciWrapper (+  Interpreter+, Config(..)+, defaultConfig+, new+, close+, eval+, evalEcho+) where++import           System.IO hiding (stdin, stdout, stderr)+import           System.Process+import           System.Exit+import           Control.Monad+import           Control.Exception+import           Data.List+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"++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 System.IO"+  _ <- eval interpreter "import GHC.IO.Handle"+  -- The buffering of stdout and stderr is NoBuffering+  _ <- eval interpreter "hDuplicateTo stdout 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 "hSetBuffering stdout LineBuffering"+  _ <- eval interpreter "hSetBuffering stderr LineBuffering"++  -- this is required on systems that don't use utf8 as default encoding (e.g.+  -- Windows)+  _ <- eval interpreter "hSetEncoding stdout utf8"+  _ <- eval interpreter "hSetEncoding stderr 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 -> String -> IO ()+putExpression Interpreter{hIn = stdin} e = do+  hPutStrLn stdin e+  hPutStrLn stdin marker+  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 expr+  getResult False repl++-- | Evaluate an expression+evalEcho :: Interpreter -> String -> IO String+evalEcho repl expr = do+  putExpression repl expr+  getResult True repl
+ driver/Client.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import           System.Exit+import           Control.Monad+import qualified Data.ByteString.Lazy as L++import           Client++main :: IO ()+main = do+  (success, output) <- client+  L.putStr output+  unless success exitFailure
+ driver/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import           System.Environment++import           Run++main :: IO ()+main = getArgs >>= run
+ driver/Web.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import           System.Environment++import           Run++main :: IO ()+main = getArgs >>= runWeb
+ sensei.cabal view
@@ -0,0 +1,166 @@+-- This file has been generated from package.yaml by hpack version 0.8.0.+--+-- see: https://github.com/sol/hpack++name:           sensei+version:        0.0.0+synopsis:       Automatically run Hspec tests on file modifications+category:       Development+homepage:       https://github.com/hspec/sensei#readme+bug-reports:    https://github.com/hspec/sensei/issues+maintainer:     Simon Hengel <sol@typeful.net>+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/hspec/sensei++library+  hs-source-dirs:+      src+    , doctest/ghci-wrapper/src/+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , base-compat >= 0.8+    , process+    , fsnotify+    , time+    , wai+    , warp+    , http-types+    , stm+    , text+    , network+    , ansi-terminal+    , directory+    , http-client+    , bytestring+    , filepath+    , unix+  exposed-modules:+      Client+      EventQueue+      HTTP+      Options+      Run+      Session+      Trigger+      Util+      Language.Haskell.GhciWrapper+  default-language: Haskell2010++executable sensei-web+  main-is: driver/Web.hs+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , base-compat >= 0.8+    , process+    , fsnotify+    , time+    , wai+    , warp+    , http-types+    , stm+    , text+    , network+    , ansi-terminal+    , directory+    , http-client+    , bytestring+    , filepath+    , unix+    , sensei+  default-language: Haskell2010++executable seito+  main-is: driver/Client.hs+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , base-compat >= 0.8+    , process+    , fsnotify+    , time+    , wai+    , warp+    , http-types+    , stm+    , text+    , network+    , ansi-terminal+    , directory+    , http-client+    , bytestring+    , filepath+    , unix+    , sensei+  default-language: Haskell2010++executable sensei+  main-is: driver/Main.hs+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , base-compat >= 0.8+    , process+    , fsnotify+    , time+    , wai+    , warp+    , http-types+    , stm+    , text+    , network+    , ansi-terminal+    , directory+    , http-client+    , bytestring+    , filepath+    , unix+    , sensei+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , base-compat >= 0.8+    , process+    , fsnotify+    , time+    , wai+    , warp+    , http-types+    , stm+    , text+    , network+    , ansi-terminal+    , directory+    , http-client+    , bytestring+    , filepath+    , unix+    , sensei+    , hspec >= 2.2.1+    , hspec-wai+    , mockery+    , silently+    , interpolate+  other-modules:+      ClientSpec+      Helper+      HTTPSpec+      OptionsSpec+      SessionSpec+      TriggerSpec+      UtilSpec+  default-language: Haskell2010
+ src/Client.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+module Client (client) where++import           Prelude ()+import           Prelude.Compat+import           Control.Monad.Compat+import           Control.Exception+import           Data.String+import           System.IO.Error+import           Network.HTTP.Client+import           Network.HTTP.Client.Internal+import           Network.HTTP.Types+import           Network.Socket hiding (recv)+import           Network.Socket.ByteString (sendAll, recv)+import qualified Data.ByteString.Lazy as L++import           HTTP (newSocket, socketAddr, socketName)++client :: IO (Bool, L.ByteString)+client = either (const $ connectError) id <$> tryJust p go+  where+    connectError :: (Bool, L.ByteString)+    connectError = (False, "could not connect to " <> fromString socketName <> "\n")++    p :: HttpException -> Maybe ()+    p e = case e of+      FailedConnectionException2 _ _ _ se -> guard (isDoesNotExistException se) >> Just ()+      _ -> Nothing++    isDoesNotExistException :: SomeException -> Bool+    isDoesNotExistException = maybe False isDoesNotExistError . fromException++    go = do+      manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection}+      request <- parseUrl "http://localhost/"+      Response{..} <- httpLbs request {checkStatus = \_ _ _ -> Nothing} manager+      return (statusIsSuccessful responseStatus, responseBody)++    newConnection _ _ _ = do+      sock <- newSocket+      connect sock socketAddr+      socketConnection sock 8192++socketConnection :: Socket -> Int -> IO Connection+socketConnection sock chunksize = makeConnection (recv sock chunksize) (sendAll sock) (sClose sock)
+ src/EventQueue.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE LambdaCase #-}+module EventQueue (+  EventQueue+, newQueue+, emitTriggerAll+, emitModified+, emitDone+, processQueue+) where++import           Prelude ()+import           Prelude.Compat++import           Control.Monad.Compat+import           Control.Concurrent (threadDelay)+import           Control.Concurrent.STM.TChan+import           Control.Monad.STM+import           Data.List.Compat++import           Util++type EventQueue = TChan Event++data Event = TriggerAll | Modified FilePath | Done+  deriving Eq++newQueue :: IO EventQueue+newQueue = atomically $ newTChan++emitTriggerAll :: EventQueue -> IO ()+emitTriggerAll chan = atomically $ writeTChan chan TriggerAll++emitModified :: FilePath -> EventQueue -> IO ()+emitModified path chan = atomically $ writeTChan chan (Modified path)++emitDone :: EventQueue -> IO ()+emitDone chan = atomically $ writeTChan chan Done++readEvents :: EventQueue -> IO [Event]+readEvents chan = do+  e <- atomically $ readTChan chan+  unless (isKeyboardInput e) $ do+    threadDelay 100000+  es <- atomically emptyQueue+  return (e : es)+  where+    isKeyboardInput :: Event -> Bool+    isKeyboardInput event = event == Done || event == TriggerAll++    emptyQueue :: STM [Event]+    emptyQueue = do+      mEvent <- tryReadTChan chan+      case mEvent of+        Nothing -> return []+        Just e -> (e :) <$> emptyQueue++processQueue :: EventQueue -> IO () -> IO () -> IO ()+processQueue chan triggerAll trigger = go+  where+    go = do+      readEvents chan >>= \case+        events | Done `elem` events -> return ()+        events | TriggerAll `elem` events -> do+          triggerAll+          go+        events -> do+          let files = (nub . sort) [p | Modified p <- events]+          withInfoColor $ do+            mapM_ putStrLn (map ("--> " ++) files)+          trigger+          go
+ src/HTTP.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+module HTTP (+  withServer+, socketName+, newSocket+, socketAddr++-- exported for testing+, app+) where++import           Prelude ()+import           Prelude.Compat+import           Data.String+import           Data.Text.Lazy.Encoding (encodeUtf8)+import           Control.Exception+import           Control.Monad+import           Control.Concurrent+import           System.IO.Error+import           System.Directory+import           Network.Wai+import           Network.HTTP.Types+import           Network.Wai.Handler.Warp+import           Network.Socket++socketName :: String+socketName = ".sensei.sock"++socketAddr :: SockAddr+socketAddr = SockAddrUnix socketName++newSocket :: IO Socket+newSocket = socket AF_UNIX Stream 0++withSocket :: (Socket -> IO a) -> IO a+withSocket action = bracket newSocket close action++withServer :: IO (Bool, String) -> IO a -> IO a+withServer trigger = withApplication (app trigger)++withApplication :: Application -> IO a -> IO a+withApplication application action = do+  removeSocketFile+  withSocket $ \sock -> do+    bracket_ (bind sock socketAddr) removeSocketFile $ do+      listen sock maxListenQueue+      withThread (runSettingsSocket defaultSettings sock application) action++removeSocketFile :: IO ()+removeSocketFile = void $ tryJust (guard . isDoesNotExistError) (removeFile socketName)++withThread :: IO () -> IO a -> IO a+withThread asyncAction action = do+  mvar <- newEmptyMVar+  tid <- forkIO $ do+    asyncAction `finally` putMVar mvar ()+  r <- action+  killThread tid+  takeMVar mvar+  return r++app :: IO (Bool, String) -> Application+app trigger _ respond = trigger >>= textPlain+  where+    textPlain (success, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs)+      where+        status+          | success = ok200+          | otherwise = internalServerError500
+ src/Options.hs view
@@ -0,0 +1,38 @@+module Options (splitArgs) where++import           Data.List+import           System.Console.GetOpt++splitArgs :: [String] -> ([String], [String])+splitArgs args = case break (== "--") $ reverse args of+  (xs, "--" : ys) -> (reverse ys, reverse xs)+  _ -> case filter isHspecArgs $ tails args of+    x : _ -> (dropEnd (length x) args, x)+    [] -> (args, [])+  where+    isHspecArgs xs = case getOpt Permute options xs of+      (_, [], []) -> True+      _ -> False++    dropEnd :: Int -> [a] -> [a]+    dropEnd n = reverse . drop n . reverse++options :: [OptDescr ()]+options = map ($ "") [+    Option []  ["help"]             (NoArg ())+  , Option "m" ["match"]            (ReqArg (const ()) "PATTERN")+  , Option []  ["skip"]             (ReqArg (const ()) "PATTERN")+  , Option []  ["color"]            (NoArg ())+  , Option []  ["no-color"]         (NoArg ())+  , Option "f" ["format"]           (ReqArg (const ()) "FORMATTER")+  , Option "o" ["out"]              (ReqArg (const ()) "FILE")+  , Option []  ["depth"]            (ReqArg (const ()) "N")+  , Option "a" ["qc-max-success"]   (ReqArg (const ()) "N")+  , Option []  ["qc-max-size"]      (ReqArg (const ()) "N")+  , Option []  ["qc-max-discard"]   (ReqArg (const ()) "N")+  , Option []  ["seed"]             (ReqArg (const ()) "N")+  , Option []  ["print-cpu-time"]   (NoArg ())+  , Option []  ["dry-run"]          (NoArg ())+  , Option []  ["fail-fast"]        (NoArg ())+  , Option "r" ["rerun"]            (NoArg ())+  ]
+ src/Run.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+module Run where+import           Prelude ()+import           Prelude.Compat++import           Control.Concurrent+import           Control.Exception+import           Control.Monad (void, forever, when)+import           Data.Foldable+import           System.Exit+import           System.FSNotify++import qualified HTTP+import qualified Session+import           Session (Session)++import           EventQueue+import           Trigger+import           Util++waitForever :: IO ()+waitForever = forever $ threadDelay 10000000++watchFiles :: EventQueue -> IO ()+watchFiles queue = void . forkIO $ do+  withManager $ \manager -> do+    _ <- watchTree manager "." (not . isBoring . eventPath) (\event -> emitModified (eventPath event) queue)+    waitForever++watchInput :: EventQueue -> IO ()+watchInput queue = void . forkIO $ do+  input <- getContents+  forM_ (lines input) $ \_ -> do+    emitTriggerAll queue+  emitDone queue++run :: [String] -> IO ()+run args = do+  withSession args $ \session -> do+    queue <- newQueue+    watchFiles queue+    watchInput queue+    lastOutput <- newMVar (True, "")+    HTTP.withServer (readMVar lastOutput) $ do+      let saveOutput :: IO (Bool, String) -> IO ()+          saveOutput action = modifyMVar_ lastOutput $ \_ -> action+          triggerAction = saveOutput (trigger session)+          triggerAllAction = saveOutput (triggerAll session)+      triggerAction+      processQueue queue triggerAllAction triggerAction++runWeb :: [String] -> IO ()+runWeb args = do+  withSession args $ \session -> do+    _ <- trigger session+    lock <- newMVar ()+    HTTP.withServer (withMVar lock $ \() -> trigger session) $ do+      waitForever++withSession :: [String] -> (Session -> IO ()) -> IO ()+withSession args action = do+  check <- dotGhciWritableByOthers+  when check $ do+    putStrLn ".ghci is writable by others, you can fix this with:"+    putStrLn ""+    putStrLn "    chmod go-w .ghci ."+    putStrLn ""+    exitFailure+  bracket (Session.new args) Session.close action
+ src/Session.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE RecordWildCards #-}+module Session (+  Session(..)+, hspecFailureEnvName+, new+, close+, reload++, Summary(..)+, isFailure+, isSuccess+, hasSpec+, hasHspecCommandSignature+, runSpec+, hspecPreviousSummary+, resetSummary+, parseSummary+) where++import           Data.IORef+import           Data.List.Compat+import           Data.Maybe (listToMaybe, catMaybes)+import           Prelude ()+import           Prelude.Compat+import           Text.Read.Compat++import qualified Language.Haskell.GhciWrapper as GhciWrapper+import           Language.Haskell.GhciWrapper hiding (new, close)++import           Util+import           Options++hspecFailureEnvName :: String+hspecFailureEnvName = "HSPEC_FAILURES"++data Session = Session {+  sessionInterpreter :: Interpreter+, sessionHspecArgs :: [String]+, sessionHspecPreviousSummary :: IORef (Maybe Summary)+}++resetSummary :: Session -> IO ()+resetSummary Session{..} = writeIORef sessionHspecPreviousSummary (Just $ Summary 0 0)++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 ("System.Environment.unsetEnv " ++ show hspecFailureEnvName)+  ref <- newIORef (Just $ Summary 0 0)+  return (Session ghci hspecArgs ref)++close :: Session -> IO ()+close = GhciWrapper.close . sessionInterpreter++reload :: Session -> IO String+reload Session{..} = evalEcho sessionInterpreter ":reload"++data Summary = Summary {+  summaryExamples :: Int+, summaryFailures :: Int+} deriving (Eq, Show, Read)++hspecCommand :: String+hspecCommand = "Test.Hspec.Runner.hspecResult spec"++hasSpec :: Session -> IO Bool+hasSpec Session{..} = hasHspecCommandSignature <$> eval sessionInterpreter (":type " ++ hspecCommand)++hasHspecCommandSignature :: String -> Bool+hasHspecCommandSignature = any match . lines . normalizeTypeSignatures+  where+    match line = (hspecCommand ++ " :: IO ") `isPrefixOf` line && "Summary" `isSuffixOf` line++runSpec :: Session -> IO String+runSpec 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 ++ " $ " ++ hspecCommand+  writeIORef sessionHspecPreviousSummary (parseSummary r)+  return r+  where+    addRerun :: [String] -> [String]+    addRerun args = "--rerun" : args++isFailure :: Maybe Summary -> Bool+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++    dropAnsiEscapeSequences xs+      | "Summary" `isPrefixOf` xs = xs+      | otherwise = case xs of+          _ : ys -> dropAnsiEscapeSequences ys+          [] -> []
+ src/Trigger.hs view
@@ -0,0 +1,41 @@+module Trigger (+  trigger+, triggerAll+) where++import           Prelude ()+import           Prelude.Compat+import           Data.List++import           Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary)+import qualified Session++triggerAll :: Session -> IO (Bool, String)+triggerAll session = do+  resetSummary session+  trigger session++trigger :: Session -> IO (Bool, String)+trigger session = do+  xs <- Session.reload session+  fmap (xs ++) <$> if "Ok, modules loaded:" `isInfixOf` xs+    then hspec+    else return (False, "")+  where+    hspec = do+      hasSpec <- Session.hasSpec session+      if hasSpec+        then runSpecs+        else return (True, "")++    runSpecs = do+      failedPreviously <- isFailure <$> hspecPreviousSummary session+      (success, xs) <- runSpec+      fmap (xs ++) <$> if success && failedPreviously+        then runSpec+        else return (success, "")++    runSpec = do+      xs <- Session.runSpec session+      success <- isSuccess <$> hspecPreviousSummary session+      return (success, xs)
+ src/Util.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings, LambdaCase #-}+module Util where++import           Prelude ()+import           Prelude.Compat++import           Control.Exception+import           Data.List.Compat+import           System.Console.ANSI+import           System.FilePath+import           System.Posix.Files+import           System.Posix.Types++withInfoColor :: IO a -> IO a+withInfoColor = bracket_ set reset+  where+    set = setSGR [SetColor Foreground Dull Magenta]+    reset = setSGR []++isBoring :: FilePath -> Bool+isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p+  where+    dirs = splitDirectories p+    isEmacsAutoSave = isPrefixOf ".#" . takeFileName++normalizeTypeSignatures :: String -> String+normalizeTypeSignatures = normalize . concatMap replace+  where+    normalize = \case+      xs | "\n  :: " `isPrefixOf` xs -> normalizeTypeSignatures (drop 2 xs)+      x : xs -> x : normalizeTypeSignatures xs+      [] -> []++    replace c = case c of+      '\8759' -> "::"+      '\8594' -> "->"+      _ -> [c]++dotGhciWritableByOthers :: IO Bool+dotGhciWritableByOthers = do+  exists <- fileExist ".ghci"+  if exists then do+    mode <- fileMode <$> getFileStatus ".ghci"+    dirMode <- fileMode <$> getFileStatus "."+    return (writableByOthers mode || writableByOthers dirMode)+  else+    return False++writableByOthers :: FileMode -> Bool+writableByOthers mode = m /= nullFileMode+  where+    m = intersectFileModes (unionFileModes otherWriteMode groupWriteMode) mode
+ test/ClientSpec.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+module ClientSpec (spec) where++import           Helper++import           HTTP+import           Client++spec :: Spec+spec = do+  describe "client" $ do+    it "does a HTTP request via a Unix domain socket" $ do+      inTempDirectory $ do+        withServer (return (True, "hello")) $ do+          client `shouldReturn` (True, "hello")++    it "indicates failure" $ do+      inTempDirectory $ do+        withServer (return (False, "hello")) $ do+          client `shouldReturn` (False, "hello")++    context "when server socket is missing" $ do+      it "reports error" $ do+        inTempDirectory $ do+          client `shouldReturn` (False, "could not connect to .sensei.sock\n")
+ test/HTTPSpec.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module HTTPSpec (spec) where++import           Test.Hspec+import           Test.Hspec.Wai++import           HTTP++spec :: Spec+spec = do+  describe "app" $ do+    with (return $ app $ return (True, "hello")) $ do+      it "returns 200 on success" $ do+        get "/" `shouldRespondWith` 200++    with (return $ app $ return (False, "hello")) $ do+      it "return 500 on failure" $ do+        get "/" `shouldRespondWith` 500
+ test/Helper.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE QuasiQuotes #-}+module Helper (+  module Test.Hspec+, module Test.Mockery.Directory+, module Control.Applicative+, module System.IO.Silently+, withSession+, withSomeSpec+, passingSpec+, failingSpec+) where++import           Control.Applicative+import           Control.Exception+import           Data.String.Interpolate+import           System.IO.Silently+import           Test.Hspec+import           Test.Mockery.Directory++import           Run ()+import qualified Session+import           Session (Session)++withSession :: [String] -> (Session -> IO a) -> IO a+withSession args action = bracket (Session.new $ "-ignore-dot-ghci" : args) Session.close action++withSomeSpec :: IO a -> IO a+withSomeSpec = (inTempDirectory .  (writeFile "Spec.hs" passingSpec >>))++passingSpec :: String+passingSpec = [i|+module Spec (spec) where++import           Test.Hspec++spec :: Spec+spec = do+  it "foo" True+  it "bar" True+|]++failingSpec :: String+failingSpec = [i|+module Spec (spec) where++import           Test.Hspec++spec :: Spec+spec = do+  it "foo" True+  it "bar" False+|]
+ test/OptionsSpec.hs view
@@ -0,0 +1,17 @@+module OptionsSpec (main, spec) where++import           Test.Hspec++import           Options++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "splitArgs" $ do+    it "returns longest matching list of Hspec arguments from end of given list" $ do+      splitArgs ["foo", "--bar", "-m", "FooSpec", "-a", "1000"] `shouldBe` (["foo", "--bar"], ["-m", "FooSpec", "-a", "1000"])++    it "assumes everything after the last '--' to be Hspec arguments" $ do+      splitArgs ["foo", "bar", "--", "foo", "baz"] `shouldBe` (["foo", "bar"], ["foo", "baz"])
+ test/SessionSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RecordWildCards #-}+module SessionSpec (spec) where++import           Language.Haskell.GhciWrapper (eval)+import           System.Environment.Compat++import           Helper++import qualified Session+import           Session (Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary)++spec :: Spec+spec = do+  describe "new" $ do+    it "unsets HSPEC_FAILURES" $ do+      setEnv hspecFailureEnvName "foo"+      withSession [] $ \Session{..} -> do+        _ <- eval sessionInterpreter "import System.Environment"+        eval sessionInterpreter ("lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n"++  describe "reload" $ do+    it "reloads" $ do+      withSession [] $ \session -> do+        silence (Session.reload session) `shouldReturn` "Ok, modules loaded: none.\n"++  describe "hasSpec" $ around_ withSomeSpec $ do+    context "when module contains spec" $ do+      it "returns True" $ do+        withSession ["Spec.hs"] $ \session -> do+          _ <- silence (Session.reload session)+          Session.hasSpec session `shouldReturn` True++    context "when module does not contain spec" $ do+      it "returns False" $ do+        withSession ["Spec.hs"] $ \session -> do+          writeFile "Spec.hs" "module Main where"+          _ <- silence (Session.reload session)+          Session.hasSpec session `shouldReturn` False++  describe "hasHspecCommandSignature" $ do+    let signature = "Test.Hspec.Runner.hspecResult spec :: IO Test.Hspec.Core.Runner.Summary"++    context "when input contains qualified Hspec command signature" $ do+      it "returns True" $ do+        Session.hasHspecCommandSignature signature `shouldBe` True++      it "ignores additional output after summary" $ do+        (Session.hasHspecCommandSignature . unlines) [+            "bar"+          , signature+          , "foo"+          ] `shouldBe` True++    context "when input contains unqualified Hspec command signature" $ do+      it "returns True" $ do+        Session.hasHspecCommandSignature "Test.Hspec.Runner.hspecResult spec :: IO Summary" `shouldBe` True++    context "when input dose not contain Hspec command signature" $ do+      it "returns False" $ do+        Session.hasHspecCommandSignature "foo" `shouldBe` False++  describe "runSpec" $ around_ withSomeSpec $ do+    it "stores summary of spec run" $ do+      withSession ["Spec.hs"] $ \session -> do+        _ <- silence (Session.runSpec session >> Session.runSpec session)+        hspecPreviousSummary session `shouldReturn` Just (Summary 2 0)++    it "accepts Hspec args" $ do+      withSession ["Spec.hs", "--no-color", "-m", "foo"] $ \session -> do+        _ <- silence (Session.runSpec session >> Session.runSpec session)+        hspecPreviousSummary session `shouldReturn` Just (Summary 1 0)++  describe "parseSummary" $ do+    let summary = Summary 2 0++    it "parses summary" $ do+      Session.parseSummary (show summary) `shouldBe` Just summary++    it "ignores additional output before / after summary" $ do+      (Session.parseSummary . unlines) [+          "foo"+        , show summary+        , "bar"+        ] `shouldBe` Just summary++    it "gives last occurrence precedence" $ do+      (Session.parseSummary . unlines) [+          show (Summary 3 0)+        , show summary+        ] `shouldBe` Just summary++    it "ignores additional output at the beginning of a line (to cope with ansi escape sequences)" $ do+      Session.parseSummary ("foo " ++ show summary) `shouldBe` Just (Summary 2 0)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TriggerSpec.hs view
@@ -0,0 +1,137 @@+module TriggerSpec (spec) where++import           Helper+import           Data.List++import           Trigger++normalize :: String -> [String]+normalize = normalizeErrors . normalizeTiming . normalizeSeed . lines+  where+    normalizeErrors :: [String] -> [String]+    normalizeErrors = mkNormalize "Spec.hs:"++    normalizeTiming :: [String] -> [String]+    normalizeTiming = mkNormalize "Finished in "++    normalizeSeed :: [String] -> [String]+    normalizeSeed = mkNormalize "Randomized with seed "++    mkNormalize :: String -> [String] -> [String]+    mkNormalize message = map f+      where+        f line+          | message `isPrefixOf` line = message ++ "..."+          | otherwise = line++spec :: Spec+spec = do+  describe "triggerAll" $ around_ withSomeSpec $ do+    it "runs all specs" $ do+      withSession ["Spec.hs", "--no-color"] $ \session -> do+        writeFile "Spec.hs" failingSpec+        (False, xs) <- silence (trigger session >> triggerAll session)+        normalize xs `shouldBe` [+            "Ok, modules loaded: Spec."+          , ""+          , "foo"+          , "bar FAILED [1]"+          , ""+          , "Failures:"+          , ""+          , "  Spec.hs:9: "+          , "  1) bar"+          , ""+          , "Randomized with seed ..."+          , ""+          , "Finished in ..."+          , "2 examples, 1 failure"+          , "Summary {summaryExamples = 2, summaryFailures = 1}"+          ]++  describe "trigger" $ around_ withSomeSpec $ do+    it "reloads and runs specs" $ do+      withSession ["Spec.hs", "--no-color"] $ \session -> do+        result <- silence (trigger session >> trigger session)+        fmap normalize result `shouldBe` (True, [+            "Ok, modules loaded: Spec."+          , ""+          , "foo"+          , "bar"+          , ""+          , "Finished in ..."+          , "2 examples, 0 failures"+          , "Summary {summaryExamples = 2, summaryFailures = 0}"+          ])++    context "with a module that does not compile" $ do+      it "stops after reloading" $ do+        withSession ["Spec.hs"] $ \session -> do+          writeFile "Spec.hs" (passingSpec ++ "foo = bar")+          (False, xs) <- silence (trigger session >> trigger session)+          normalize xs `shouldBe` [+              "[1 of 1] Compiling Spec             ( Spec.hs, interpreted )"+            , ""+            , "Spec.hs:..."+            , "Failed, modules loaded: none."+            ]++    context "with a failing spec" $ do+      it "indicates failure" $ do+        withSession ["Spec.hs"] $ \session -> do+          writeFile "Spec.hs" failingSpec+          (False, xs) <- silence (trigger session)+          xs `shouldContain` "Ok, modules loaded:"+          xs `shouldContain` "2 examples, 1 failure"++      it "only reruns failing specs" $ do+        withSession ["Spec.hs", "--no-color"] $ \session -> do+          writeFile "Spec.hs" failingSpec+          (False, xs) <- silence (trigger session >> trigger session)+          normalize xs `shouldBe` [+              "Ok, modules loaded: Spec."+            , ""+            , "bar FAILED [1]"+            , ""+            , "Failures:"+            , ""+            , "  Spec.hs:9: "+            , "  1) bar"+            , ""+            , "Randomized with seed ..."+            , ""+            , "Finished in ..."+            , "1 example, 1 failure"+            , "Summary {summaryExamples = 1, summaryFailures = 1}"+            ]++    context "after a failing spec passes" $ do+      it "runs all specs" $ do+        withSession ["Spec.hs", "--no-color"] $ \session -> do+          writeFile "Spec.hs" failingSpec+          _ <- silence (trigger session)+          writeFile "Spec.hs" passingSpec+          (True, xs) <- silence (trigger session)+          normalize xs `shouldBe` [+              "[1 of 1] Compiling Spec             ( Spec.hs, interpreted )"+            , "Ok, modules loaded: Spec."+            , ""+            , "bar"+            , ""+            , "Finished in ..."+            , "1 example, 0 failures"+            , "Summary {summaryExamples = 1, summaryFailures = 0}"+            , ""+            , "foo"+            , "bar"+            , ""+            , "Finished in ..."+            , "2 examples, 0 failures"+            , "Summary {summaryExamples = 2, summaryFailures = 0}"+            ]++    context "with a module that does not expose a spec" $ do+      it "only reloads" $ do+        withSession ["Spec.hs"] $ \session -> do+          writeFile "Spec.hs" "module Main where"+          silence (trigger session >> trigger session) `shouldReturn` (True, "Ok, modules loaded: Main.\n")
+ test/UtilSpec.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module UtilSpec (spec) where++import           Helper++import           System.Posix.Files+import           System.Process++import           Util++spec :: Spec+spec = do+  describe "isBoring" $ do+    it "ignores files in .git/" $ do+      isBoring "/foo/bar/.git/baz/foo.txt" `shouldBe` True++    it "ignores files in dist/" $ do+      isBoring "/foo/bar/dist/baz/foo.txt" `shouldBe` True++  describe "normalizeTypeSignatures" $ do+    it "removes newlines from type signatures" $ do+      normalizeTypeSignatures "foo\n  :: Int" `shouldBe` "foo :: Int"++    it "replaces unicode characters" $ do+      normalizeTypeSignatures "head ∷ [a] → a" `shouldBe` "head :: [a] -> a"++  describe "dotGhciWritableByOthers" $ do+    around_ inTempDirectory $ do+      before_ (touch ".ghci" >> callCommand "chmod go-w .ghci") $ do+        it "returns False" $ do+          dotGhciWritableByOthers `shouldReturn` False++        context "when writable by group" $ do+          it "returns True" $ do+            callCommand "chmod g+w .ghci"+            dotGhciWritableByOthers `shouldReturn` True++        context "when writable by others" $ do+          it "returns True" $ do+            callCommand "chmod o+w .ghci"+            dotGhciWritableByOthers `shouldReturn` True++        context "when directory is writable by group" $ do+          it "returns True" $ do+            callCommand "chmod g+w ."+            dotGhciWritableByOthers `shouldReturn` True++      context "when .ghci does not exist" $ do+        it "returns False" $ do+          dotGhciWritableByOthers `shouldReturn` False++  describe "writableByOthers" $ do+    it "returns False for owner" $ do+      writableByOthers ownerWriteMode `shouldBe` False++    it "returns True for group" $ do+      writableByOthers groupWriteMode `shouldBe` True++    it "returns True for others" $ do+      writableByOthers otherWriteMode `shouldBe` True