sensei 0.7.0 → 0.8.0
raw patch · 30 files changed
+1514/−575 lines, 30 filesdep +aesondep +asyncdep +casingdep −silentlydep ~bytestringdep ~hspec
Dependencies added: aeson, async, casing, containers, mtl, temporary, transformers, yaml
Dependencies removed: silently
Dependency ranges changed: bytestring, hspec
Files
- driver/seito.hs +1/−1
- sensei.cabal +135/−51
- src/Client.hs +4/−5
- src/Config.hs +114/−0
- src/EventQueue.hs +76/−39
- src/HTTP.hs +23/−20
- src/Imports.hs +22/−3
- src/Input.hs +39/−0
- src/Language/Haskell/GhciWrapper.hs +70/−55
- src/Options.hs +53/−20
- src/Pager.hs +28/−0
- src/ReadHandle.hs +10/−24
- src/Run.hs +134/−65
- src/Session.hs +29/−25
- src/Trigger.hs +88/−31
- src/Util.hs +27/−23
- test/ClientSpec.hs +9/−9
- test/ConfigSpec.hs +114/−0
- test/EventQueueSpec.hs +63/−26
- test/HTTPSpec.hs +3/−3
- test/Helper.hs +32/−19
- test/Language/Haskell/GhciWrapperSpec.hs +42/−7
- test/OptionsSpec.hs +12/−2
- test/PagerSpec.hs +51/−0
- test/ReadHandleSpec.hs +4/−6
- test/RunSpec.hs +70/−0
- test/SessionSpec.hs +32/−25
- test/SpecHook.hs +7/−0
- test/TriggerSpec.hs +179/−87
- test/UtilSpec.hs +43/−29
driver/seito.hs view
@@ -8,6 +8,6 @@ main :: IO () main = do- (success, output) <- client+ (success, output) <- client "" L.putStr output unless success exitFailure
sensei.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: sensei-version: 0.7.0+version: 0.8.0 synopsis: Automatically run Hspec tests on file modifications category: Development homepage: https://github.com/hspec/sensei#readme@@ -23,133 +23,237 @@ executable seito main-is: seito.hs+ other-modules:+ Client+ Config+ EventQueue+ HTTP+ Imports+ Input+ Language.Haskell.GhciWrapper+ Options+ Pager+ ReadHandle+ Run+ Session+ Trigger+ Util+ Paths_sensei hs-source-dirs: src driver- ghc-options: -Wall+ default-extensions:+ DuplicateRecordFields+ LambdaCase+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns+ other-extensions:+ NoFieldSelectors+ ghc-options: -Wall -threaded build-depends:- ansi-terminal+ aeson+ , ansi-terminal+ , async , base >=4.11 && <5- , bytestring+ , bytestring >=0.11+ , casing+ , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types+ , mtl , network , process , stm , text , time+ , transformers , unix , wai , warp+ , yaml+ default-language: GHC2021++executable sensei+ main-is: sensei.hs other-modules: Client+ Config EventQueue HTTP Imports+ Input Language.Haskell.GhciWrapper Options+ Pager ReadHandle Run Session Trigger Util Paths_sensei- default-language: Haskell2010--executable sensei- main-is: sensei.hs hs-source-dirs: src driver- ghc-options: -Wall+ default-extensions:+ DuplicateRecordFields+ LambdaCase+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns+ other-extensions:+ NoFieldSelectors+ ghc-options: -Wall -threaded build-depends:- ansi-terminal+ aeson+ , ansi-terminal+ , async , base >=4.11 && <5- , bytestring+ , bytestring >=0.11+ , casing+ , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types+ , mtl , network , process , stm , text , time+ , transformers , unix , wai , warp+ , yaml+ default-language: GHC2021++executable sensei-web+ main-is: sensei-web.hs other-modules: Client+ Config EventQueue HTTP Imports+ Input Language.Haskell.GhciWrapper Options+ Pager ReadHandle Run Session Trigger Util Paths_sensei- default-language: Haskell2010--executable sensei-web- main-is: sensei-web.hs hs-source-dirs: src driver- ghc-options: -Wall+ default-extensions:+ DuplicateRecordFields+ LambdaCase+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns+ other-extensions:+ NoFieldSelectors+ ghc-options: -Wall -threaded build-depends:- ansi-terminal+ aeson+ , ansi-terminal+ , async , base >=4.11 && <5- , bytestring+ , bytestring >=0.11+ , casing+ , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types+ , mtl , network , process , stm , text , time+ , transformers , unix , wai , warp+ , yaml+ default-language: GHC2021++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs other-modules: Client+ Config EventQueue HTTP Imports+ Input Language.Haskell.GhciWrapper Options+ Pager ReadHandle Run Session Trigger Util+ ClientSpec+ ConfigSpec+ EventQueueSpec+ Helper+ HTTPSpec+ Language.Haskell.GhciWrapperSpec+ OptionsSpec+ PagerSpec+ ReadHandleSpec+ RunSpec+ SessionSpec+ SpecHook+ TriggerSpec+ UtilSpec Paths_sensei- default-language: Haskell2010--test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs hs-source-dirs: src test- ghc-options: -Wall+ default-extensions:+ DuplicateRecordFields+ LambdaCase+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns+ other-extensions:+ NoFieldSelectors+ ghc-options: -Wall -threaded cpp-options: -DTEST build-tool-depends: hspec-discover:hspec-discover build-depends: QuickCheck+ , aeson , ansi-terminal+ , async , base >=4.11 && <5- , bytestring+ , bytestring >=0.11+ , casing+ , containers , directory , filepath , fsnotify ==0.4.*@@ -159,36 +263,16 @@ , http-client >=0.5.0 , http-types , mockery+ , mtl , network , process- , silently , stm+ , temporary , text , time+ , transformers , unix , wai , warp- other-modules:- Client- EventQueue- HTTP- Imports- Language.Haskell.GhciWrapper- Options- ReadHandle- Run- Session- Trigger- Util- ClientSpec- EventQueueSpec- Helper- HTTPSpec- Language.Haskell.GhciWrapperSpec- OptionsSpec- ReadHandleSpec- SessionSpec- TriggerSpec- UtilSpec- Paths_sensei- default-language: Haskell2010+ , yaml+ default-language: GHC2021
src/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Client (client) where import Imports@@ -11,11 +10,11 @@ import HTTP (newSocket, socketAddr, socketName) -client :: IO (Bool, L.ByteString)-client = either (const $ connectError) id <$> tryJust p go+client :: FilePath -> IO (Bool, L.ByteString)+client dir = fromRight connectError <$> tryJust p go where connectError :: (Bool, L.ByteString)- connectError = (False, "could not connect to " <> fromString socketName <> "\n")+ connectError = (False, "could not connect to " <> fromString (socketName dir) <> "\n") p :: HttpException -> Maybe () p e = case e of@@ -32,5 +31,5 @@ newConnection _ _ _ = do sock <- newSocket- connect sock socketAddr+ connect sock $ socketAddr dir socketConnection sock 8192
+ src/Config.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+module Config (+ Config(..)+, Hook+, HookResult(..)+, defaultConfig+, loadConfig+#ifdef TEST+, ConfigFile(..)+, readConfigFilesFrom+#endif+) where++import Imports++import GHC.Generics+import Data.ByteString qualified as ByteString+import System.Directory+import System.Process+import Text.Casing+import Data.Aeson+import Data.Yaml++import Util++configFilename :: FilePath+configFilename = "sensei.yaml"++data ConfigFile = ConfigFile {+ -- | Shell command to run after a file has changed, but before reloading. Cancels the current+ -- trigger cycle when exiting with non-zero exit code.+ beforeReload :: Maybe String+ -- | Shell command to run after a successful reload, but before running the tests. Cancels the+ -- current trigger cycle when exiting with non-zero exit code.+, afterReload :: Maybe String+ -- | Shell command to run after the trigger cycle completed with failure. Has access to the result+ -- via seito.+, onFailure :: Maybe String+ -- | Shell command to run after the trigger cycle successfully completed. Has access to the result+ -- via seito.+, onSuccess :: Maybe String+} deriving (Generic, Show, Eq)++instance Semigroup ConfigFile where+ a <> b = ConfigFile {+ beforeReload = a.beforeReload <|> b.beforeReload+ , afterReload = a.afterReload <|> b.afterReload+ , onFailure = a.onFailure <|> b.onFailure+ , onSuccess = a.onSuccess <|> b.onSuccess+ }++instance Monoid ConfigFile where+ mempty = ConfigFile Nothing Nothing Nothing Nothing++instance FromJSON ConfigFile where+ parseJSON = \ case+ Null -> return mempty+ value -> genericParseJSON defaultOptions {+ fieldLabelModifier = kebab+ , rejectUnknownFields = True+ } value++type Hook = IO HookResult++data HookResult = HookSuccess | HookFailure String++data Config = Config {+ senseiHooksBeforeReload :: Hook+, senseiHooksAfterReload :: Hook+, senseiHooksOnSuccess :: Hook+, senseiHooksOnFailure :: Hook+}++tryReadFile :: FilePath -> IO (Maybe ByteString)+tryReadFile = fmap (either (const Nothing) Just) . tryJust (guard . isDoesNotExistError) . ByteString.readFile++readConfigFile :: FilePath -> IO (Either String ConfigFile)+readConfigFile path = tryReadFile path >>= \ case+ Just input -> return $ first displayException . decodeEither' $ input+ Nothing -> return $ Right mempty++readConfigFiles :: IO (Either String ConfigFile)+readConfigFiles = do+ configDir <- getXdgDirectory XdgConfig "sensei"+ readConfigFilesFrom (configDir </> configFilename) configFilename++readConfigFilesFrom :: FilePath -> FilePath -> IO (Either String ConfigFile)+readConfigFilesFrom global local = fmap mconcat . sequence <$> sequence [+ readConfigFile local+ , readConfigFile global+ ]++toConfig :: ConfigFile -> Config+toConfig ConfigFile{..} = Config {+ senseiHooksBeforeReload = maybeToHook "before-reload" beforeReload+, senseiHooksAfterReload = maybeToHook "after-reload" afterReload+, senseiHooksOnSuccess = maybeToHook "on-success" onSuccess+, senseiHooksOnFailure = maybeToHook "on-failure" onFailure+} where+ maybeToHook :: String -> Maybe String -> Hook+ maybeToHook name = maybe (return HookSuccess) (toHook name)++ toHook :: String -> String -> Hook+ toHook name command = system command >>= \ case+ ExitSuccess -> return HookSuccess+ ExitFailure code -> do+ let message = withColor Red $ name <> ": " <> command <> " # failed with status " <> show code+ return $ HookFailure message++defaultConfig :: Config+defaultConfig = toConfig mempty++loadConfig :: IO Config+loadConfig = readConfigFiles >>= either (throwIO . ErrorCall) (return . toConfig)
src/EventQueue.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} module EventQueue ( EventQueue@@ -21,6 +20,7 @@ ) where import Imports+import qualified Data.Set as Set import Control.Monad.STM import Control.Concurrent.STM.TChan@@ -29,14 +29,18 @@ type EventQueue = TChan Event -data Event = TriggerAll | FileEvent FileEventType FilePath | Done+data Event =+ TriggerAll+ | FileEvent FileEventType FilePath+ | RestartWith [String]+ | Done deriving (Eq, Show) data FileEventType = FileAdded | FileRemoved | FileModified deriving (Eq, Show) newQueue :: IO EventQueue-newQueue = atomically $ newTChan+newQueue = atomically newTChan emitEvent :: EventQueue -> Event -> IO () emitEvent chan = atomically . writeTChan chan@@ -45,12 +49,16 @@ readEvents chan = do e <- atomically $ readTChan chan unless (isKeyboardInput e) $ do- threadDelay 100000+ threadDelay 100_000 es <- atomically emptyQueue return (e : es) where isKeyboardInput :: Event -> Bool- isKeyboardInput event = event == Done || event == TriggerAll+ isKeyboardInput = \ case+ TriggerAll -> True+ FileEvent {} -> False+ RestartWith {} -> True+ Done -> True emptyQueue :: STM [Event] emptyQueue = do@@ -59,54 +67,83 @@ Nothing -> return [] Just e -> (e :) <$> emptyQueue -data Status = Terminate | Reload+data Status = Terminate | Restart (Maybe [String])+ deriving (Eq, Show) -processQueue :: EventQueue -> IO () -> IO () -> IO Status-processQueue chan triggerAll trigger = go+processQueue :: IO () -> (String -> IO ()) -> FilePath -> EventQueue -> IO () -> IO () -> IO Status+processQueue cleanup echo dir chan triggerAll trigger = go where- go = readEvents chan >>= processEvents >>= \ case- NoneAction -> do- go- TriggerAction files -> do- output files- trigger- go- TriggerAllAction -> do- triggerAll- go- ReloadAction file t -> do- output [file <> " (" <> show t <> ", reloading)"]- return Reload- DoneAction -> do- return Terminate+ go :: IO Status+ go = do+ action <- readEvents chan >>= processEvents echo dir+ runCleanup action+ case action of+ NoneAction -> do+ go+ TriggerAction files -> do+ output files+ trigger+ go+ TriggerAllAction -> do+ triggerAll+ go+ RestartAction file t -> do+ output [file <> " (" <> show t <> ", restarting)"]+ return $ Restart Nothing+ RestartWithAction args -> do+ return $ Restart (Just args)+ DoneAction -> do+ return Terminate + runCleanup :: Action -> IO ()+ runCleanup = \ case+ NoneAction -> pass+ TriggerAction {} -> cleanup+ TriggerAllAction -> cleanup+ RestartAction {} -> cleanup+ RestartWithAction {} -> cleanup+ DoneAction -> cleanup+ output :: [String] -> IO ()- output = withInfoColor . mapM_ (putStrLn . mappend "--> ")+ output = mapM_ (\ name -> echo . withInfoColor $ "--> " <> name <> "\n") -data Action = NoneAction | TriggerAction [FilePath] | TriggerAllAction | ReloadAction FilePath FileEventType | DoneAction+data Action =+ NoneAction+ | TriggerAction [FilePath]+ | TriggerAllAction+ | RestartAction FilePath FileEventType+ | RestartWithAction [String]+ | DoneAction deriving (Eq, Show) -processEvents :: [Event] -> IO Action-processEvents events = do- files <- fileEvents events+processEvents :: (String -> IO ()) -> FilePath -> [Event] -> IO Action+processEvents echo dir events = do+ files <- fileEvents echo dir events return $ if | Done `elem` events -> DoneAction- | (file, t) : _ <- filter shouldReload files -> ReloadAction file t+ | args : _ <- [args | RestartWith args <- reverse events] -> RestartWithAction args+ | (file, t) : _ <- filter shouldRestart files -> RestartAction file t | TriggerAll `elem` events -> TriggerAllAction- | not (null files) -> TriggerAction $ nub . sort $ map fst files+ | not (null files) -> TriggerAction . Set.toList . Set.fromList $ map fst files | otherwise -> NoneAction -shouldReload :: (FilePath, FileEventType) -> Bool-shouldReload (name, event) = "Spec.hs" `isSuffixOf` name && case event of- FileAdded -> True- FileRemoved -> True- FileModified -> False+shouldRestart :: (FilePath, FileEventType) -> Bool+shouldRestart = (||) <$> specAddedOrRemoved <*> dotGhciModified+ where+ specAddedOrRemoved :: (FilePath, FileEventType) -> Bool+ specAddedOrRemoved (name, event) = "Spec.hs" `isSuffixOf` name && case event of+ FileAdded -> True+ FileRemoved -> True+ FileModified -> False -fileEvents :: [Event] -> IO [(FilePath, FileEventType)]-fileEvents events = filterGitIgnored $ combineFileEvents [(p, e) | FileEvent e p <- events]+ dotGhciModified :: (FilePath, FileEventType) -> Bool+ dotGhciModified (name, _) = takeFileName name == ".ghci" -filterGitIgnored :: [(FilePath, FileEventType)] -> IO [(FilePath, FileEventType)]-filterGitIgnored events = map f <$> filterGitIgnoredFiles (map fst events)+fileEvents :: (String -> IO ()) -> FilePath -> [Event] -> IO [(FilePath, FileEventType)]+fileEvents echo dir events = filterGitIgnored echo dir $ combineFileEvents [(p, e) | FileEvent e p <- events]++filterGitIgnored :: (String -> IO ()) -> FilePath -> [(FilePath, FileEventType)] -> IO [(FilePath, FileEventType)]+filterGitIgnored echo dir events = map f <$> filterGitIgnoredFiles echo dir (map fst events) where f :: FilePath -> (FilePath, FileEventType) f p = (p, fromJust $ lookup p events)
src/HTTP.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} module HTTP ( withServer , socketName@@ -14,36 +13,39 @@ import Imports import System.Directory+import Data.Text.Lazy.Encoding (encodeUtf8) import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings) import Network.Socket -socketName :: String-socketName = ".sensei.sock"+import qualified Trigger -socketAddr :: SockAddr-socketAddr = SockAddrUnix socketName+socketName :: FilePath -> String+socketName dir = dir </> ".sensei.sock" +socketAddr :: FilePath -> 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+withSocket = bracket newSocket close -withServer :: IO (Bool, String) -> IO a -> IO a-withServer trigger = withApplication (app trigger)+withServer :: FilePath -> IO (Trigger.Result, String) -> IO a -> IO a+withServer dir trigger = withApplication dir (app trigger) -withApplication :: Application -> IO a -> IO a-withApplication application action = do- removeSocketFile- withSocket $ \sock -> do- bracket_ (bind sock socketAddr) removeSocketFile $ do+withApplication :: FilePath -> Application -> IO a -> IO a+withApplication dir application action = do+ removeSocketFile dir+ withSocket $ \ sock -> do+ bracket_ (bind sock $ socketAddr dir) (removeSocketFile dir) $ do listen sock maxListenQueue withThread (runSettingsSocket defaultSettings sock application) action -removeSocketFile :: IO ()-removeSocketFile = void $ tryJust (guard . isDoesNotExistError) (removeFile socketName)+removeSocketFile :: FilePath -> IO ()+removeSocketFile dir = void $ tryJust (guard . isDoesNotExistError) (removeFile $ socketName dir) withThread :: IO () -> IO a -> IO a withThread asyncAction action = do@@ -55,11 +57,12 @@ takeMVar mvar return r -app :: IO (Bool, String) -> Application+app :: IO (Trigger.Result, String) -> Application app trigger _ respond = trigger >>= textPlain where- textPlain (success, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs)+ textPlain (result, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs) where- status- | success = ok200- | otherwise = internalServerError500+ status = case result of+ Trigger.HookFailed -> internalServerError500+ Trigger.Failure -> internalServerError500+ Trigger.Success -> ok200
src/Imports.hs view
@@ -1,21 +1,31 @@+{-# LANGUAGE CPP #-} module Imports (module Imports) where import Control.Arrow as Imports ((>>>), (&&&)) import Control.Concurrent as Imports-import Control.Exception as Imports+import Control.Exception as Imports hiding (handle) import Control.Monad as Imports-import Data.Functor as Imports+import Data.Function as Imports (fix)+import Control.Applicative as Imports+import Data.Functor as Imports ((<&>)) import Data.Bifunctor as Imports import Data.Char as Imports+import Data.Either 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.FilePath as Imports hiding (combine) import System.IO.Error as Imports (isDoesNotExistError) import Text.Read as Imports (readMaybe)+import System.Exit as Imports (ExitCode(..))+import System.Process as Process+import Control.Monad.IO.Class as Imports +import System.IO (Handle)+import GHC.IO.Handle.Internals (wantReadableHandle_)+ pass :: Applicative m => m () pass = pure () @@ -27,3 +37,12 @@ when notDone $ do action go++withLockedHandle :: Handle -> IO a -> IO a+withLockedHandle h = wantReadableHandle_ "pager" h . const++createPipe :: IO (Handle, Handle)+#if defined(__IO_MANAGER_WINIO__)+#error Use `associateHandle'` as per https://hackage.haskell.org/package/process-1.6.17.0/docs/System-Process.html#v:createPipe+#endif+createPipe = Process.createPipe
+ src/Input.hs view
@@ -0,0 +1,39 @@+module Input (watch) where++import Imports++import System.IO+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8++watch :: Handle -> (Char -> IO ()) -> IO () -> IO ()+watch handle dispatch onEof = void . forkIO $ do+ forEachInputChar handle dispatch `finally` onEof++forEachInputChar :: Handle -> (Char -> IO ()) -> IO ()+forEachInputChar handle action = do+ hSetBuffering handle NoBuffering+ hSetEcho handle False+ go+ where+ chunkSize :: Int+ chunkSize = 64++ inputDelay :: Int+ inputDelay = 100_000++ go :: IO ()+ go = ByteString.hGetNonBlocking handle chunkSize >>= \ case+ "" -> threadDelay inputDelay >> go+ cs -> consume (Char8.unpack cs)++ consume :: [Char] -> IO ()+ consume = \ case+ c : _ | eof c -> pass+ c : cs -> do+ when (isAscii c) (action c)+ consume cs+ [] -> go++ eof :: Char -> Bool+ eof = (== '\EOT')
src/Language/Haskell/GhciWrapper.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-} module Language.Haskell.GhciWrapper ( Config(..)-, Interpreter+, Interpreter(echo) , withInterpreter , eval , evalVerbose@@ -10,98 +9,127 @@ import Imports -import qualified Data.ByteString as B+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 qualified System.IO as System-import System.Directory (doesFileExist)-import System.Process-import System.Exit (ExitCode(..))+import System.Directory (doesFileExist, makeAbsolute)+import System.Environment (getEnvironment)+import System.Process hiding (createPipe)+import System.Exit (exitFailure) +import Util (isWritableByOthers) import qualified ReadHandle import ReadHandle (ReadHandle, toReadHandle) data Config = Config { configIgnoreDotGhci :: Bool-, configVerbose :: Bool , configStartupFile :: FilePath-} deriving (Eq, Show)+, configWorkingDirectory :: Maybe FilePath+, configEcho :: ByteString -> IO ()+} data Interpreter = Interpreter { hIn :: Handle , hOut :: Handle , readHandle :: ReadHandle , process :: ProcessHandle+, echo :: ByteString -> IO () } 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)+withInterpreter config args = bracket (new config args) close -new :: Config -> [String] -> IO Interpreter-new config@Config{..} args_ = do+sanitizeEnv :: [(String, String)] -> [(String, String)]+sanitizeEnv = filter p+ where+ p ("HSPEC_FAILURES", _) = False+ p _ = True +new :: Config -> [String] -> IO Interpreter+new Config{..} args_ = do+ checkDotGhci requireFile configStartupFile+ startupFile <- makeAbsolute configStartupFile+ env <- sanitizeEnv <$> getEnvironment+ let+ args = "-ghci-script" : startupFile : args_ ++ catMaybes [+ if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing+ ] - (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess (proc "ghci" args) {- std_in = CreatePipe- , std_out = CreatePipe- , std_err = Inherit+ (stdoutReadEnd, stdoutWriteEnd) <- createPipe++ (Just stdin_, Nothing, Nothing, processHandle ) <- createProcess (proc "ghci" args) {+ cwd = configWorkingDirectory+ , env = Just env+ , std_in = CreatePipe+ , std_out = UseHandle stdoutWriteEnd+ , std_err = UseHandle stdoutWriteEnd } setMode stdin_- readHandle <- toReadHandle stdout_ 1024+ readHandle <- toReadHandle stdoutReadEnd 1024 let interpreter = Interpreter { hIn = stdin_ , readHandle- , hOut = stdout_+ , hOut = stdoutReadEnd , process = processHandle+ , echo = configEcho } - _ <- 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"+ _ <- printStartupMessages interpreter+ getProcessExitCode processHandle >>= \ case+ Just _ -> exitFailure+ Nothing -> do+ -- 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"+ 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+ return interpreter where+ checkDotGhci = unless configIgnoreDotGhci $ do+ let dotGhci = fromMaybe "" configWorkingDirectory </> ".ghci"+ isWritableByOthers dotGhci >>= \ case+ False -> pass+ True -> die $ unlines [+ dotGhci <> " is writable by others, you can fix this with:"+ , ""+ , " chmod go-w " <> dotGhci <> " ."+ , ""+ ]+ 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 ""+ printStartupMessages :: Interpreter -> IO String+ printStartupMessages interpreter = evalVerbose interpreter "" evalThrow :: Interpreter -> String -> IO () evalThrow interpreter expr = do output <- eval interpreter expr unless (null output) $ do- close (verbosity config) interpreter+ close interpreter die output -close :: (ByteString -> IO ()) -> Interpreter -> IO ()-close echo Interpreter{..} = do+close :: Interpreter -> IO ()+close Interpreter{..} = do hClose hIn ReadHandle.drain readHandle echo hClose hOut@@ -112,30 +140,17 @@ putExpression :: Interpreter -> String -> IO () putExpression Interpreter{hIn = stdin} e = do hPutStrLn stdin e- B.hPut stdin ReadHandle.marker+ ByteString.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+getResult :: Interpreter -> IO String+getResult Interpreter{..} = T.unpack . decodeUtf8 <$> ReadHandle.getResult readHandle echo 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+eval ghci = evalVerbose ghci {echo = silent} evalVerbose :: Interpreter -> String -> IO String-evalVerbose = evalWith verbose+evalVerbose ghci expr = putExpression ghci expr >> getResult ghci
src/Options.hs view
@@ -11,30 +11,63 @@ x : _ -> (dropEnd (length x) args, x) [] -> (args, []) where+ isHspecArgs :: [String] -> Bool isHspecArgs xs = case getOpt Permute options xs of- (_, [], []) -> True+ (result, [], []) -> all (== Valid) result _ -> 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 [] ["focused-only"] (NoArg ())- , Option [] ["dry-run"] (NoArg ())- , Option [] ["fail-fast"] (NoArg ())- , Option "r" ["rerun"] (NoArg ())+data Valid = Valid | Invalid+ deriving (Eq, Show)++options :: [OptDescr Valid]+options = concat [+ flag "color"+ , flag "diff"+ , flag "dry-run"+ , flag "expert"+ , flag "fail-fast"+ , flag "fail-on=ITEMS"+ , flag "focused-only"+ , flag "pretty"+ , flag "randomize"+ , flag "strict"+ , flag "times"+ , flag "unicode"+ , noArg "" "help"+ , noArg "" "ignore-dot-hspec"+ , noArg "" "print-cpu-time"+ , noArg "" "rerun-all-on-success"+ , noArg "r" "rerun"+ , reqArg "" "depth" "N"+ , reqArg "" "diff-command" "CMD"+ , reqArg "" "diff-context" "N"+ , reqArg "" "failure-report" "FILE"+ , reqArg "" "jobs" "N"+ , reqArg "" "qc-max-discard" "N"+ , reqArg "" "qc-max-shrinks" "N"+ , reqArg "" "qc-max-size" "N"+ , reqArg "" "seed" "N"+ , reqArg "" "skip" "PATTERN"+ , reqArg "a" "qc-max-success" "N"+ , reqArg "f" "format" "NAME"+ , reqArg "m" "match" "PATTERN"+ , [Option "p" ["print-slow-items"] (OptArg (maybe Valid intArg) "N") ""] ]+ where+ flag :: String -> [OptDescr Valid]+ flag name = concat [+ noArg "" name+ , noArg "" ("no-" <> name)+ ]++ noArg :: [Char] -> String -> [OptDescr Valid]+ noArg short name = [Option short [name] (NoArg Valid) ""]++ reqArg :: [Char] -> String -> String -> [OptDescr Valid]+ reqArg short name arg = [Option short [name] (ReqArg (const Valid) arg) ""]++ intArg :: String -> Valid+ intArg = maybe Invalid (const Valid) . readMaybe @Int
+ src/Pager.hs view
@@ -0,0 +1,28 @@+module Pager where++import Imports++import System.IO+import System.IO.Error+import System.Process+import Control.Concurrent.Async++pager :: String -> IO (IO ())+pager = pagerWith less+ where+ less = proc "less" $ "--RAW" : "--QUIT-AT-EOF" : matchOptions++matchOptions :: [String]+matchOptions = ["--incsearch", "--pattern", "^.*\\w:\\d+:\\d+:.+$|"]++pagerWith :: CreateProcess -> String -> IO (IO ())+pagerWith process input = do+ pid <- newEmptyMVar+ tid <- async $ withLockedHandle stdin $ do+ (Just hin, Nothing, Nothing, p) <- createProcess process { delegate_ctlc = True, std_in = CreatePipe }+ putMVar pid p+ _ <- tryJust (guard . isResourceVanishedError) $ hPutStr hin input >> hClose hin+ waitForProcess p+ return $ do+ readMVar pid >>= terminateProcess+ void $ wait tid
src/ReadHandle.hs view
@@ -1,9 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-} module ReadHandle ( ReadHandle(..) , toReadHandle@@ -17,20 +12,11 @@ import Imports -import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Char8 as ByteString 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. --@@ -41,7 +27,7 @@ marker = pack (show @String "be77d2c8427d29cd1d62b7612d8e98cc") <> "\n" partialMarkers :: [ByteString]-partialMarkers = reverse . drop 1 . init $ B.inits marker+partialMarkers = reverse . drop 1 . init $ ByteString.inits marker data ReadHandle = ReadHandle { getChunk :: IO ByteString@@ -70,7 +56,7 @@ mkBufferChunk :: ByteString -> Buffer mkBufferChunk chunk- | B.null chunk = BufferEmpty+ | ByteString.null chunk = BufferEmpty | otherwise = BufferChunk chunk data Buffer =@@ -82,7 +68,7 @@ toReadHandle :: Handle -> Int -> IO ReadHandle toReadHandle h n = do hSetBinaryMode h True- ReadHandle (B.hGetSome h n) <$> newEmptyBuffer+ ReadHandle (ByteString.hGetSome h n) <$> newEmptyBuffer newEmptyBuffer :: IO (IORef Buffer) newEmptyBuffer = newIORef BufferEmpty@@ -113,7 +99,7 @@ getSome :: IO (Maybe ByteString) getSome = do chunk <- getChunk- if B.null chunk then do+ if ByteString.null chunk then do putBuffer BufferEOF return Nothing else do@@ -141,7 +127,7 @@ NoMarker -> case splitPartialMarker chunk of Just (prefix, partialMarker) -> do putBuffer (BufferPartialMarker partialMarker)- if B.null prefix then do+ if ByteString.null prefix then do go else do return (Chunk prefix)@@ -150,10 +136,10 @@ splitPartialMarker :: ByteString -> Maybe (ByteString, ByteString) splitPartialMarker chunk = split <$> findPartialMarker chunk where- split partialMarker = (dropEnd (B.length partialMarker) chunk, partialMarker)+ split partialMarker = (dropEnd (ByteString.length partialMarker) chunk, partialMarker) findPartialMarker :: ByteString -> Maybe ByteString-findPartialMarker chunk = find (`B.isSuffixOf` chunk) partialMarkers+findPartialMarker chunk = find (`ByteString.isSuffixOf` chunk) partialMarkers data StripMarker = NoMarker@@ -166,5 +152,5 @@ ("", dropMarker -> ys) -> StrippedMarker ys (xs, ys) -> PrefixBeforeMarker xs ys where- brakeAtMarker = B.breakSubstring marker- dropMarker = B.drop (B.length marker)+ brakeAtMarker = ByteString.breakSubstring marker+ dropMarker = ByteString.drop (ByteString.length marker)
src/Run.hs view
@@ -1,98 +1,167 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} module Run ( run , runWeb+#ifdef TEST+, RunArgs(..)+, runWith+, defaultRunArgs+, watchFiles+#endif ) where import Imports -import System.Exit-import System.FSNotify+import qualified Data.ByteString as ByteString+import Data.IORef+import System.IO+import qualified System.FSNotify as FSNotify import qualified HTTP import qualified Session-import Session (Session, Config(..)) import EventQueue import Trigger+import qualified Input+import Pager (pager) import Util+import Config waitForever :: IO () waitForever = forever $ threadDelay 10000000 -watchFiles :: EventQueue -> IO ()-watchFiles queue = do- 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+watchFiles :: FilePath -> EventQueue -> IO () -> IO ()+watchFiles dir queue action = do+ FSNotify.withManager $ \ manager -> do+ bracket (FSNotify.watchTree manager dir isInteresting dispatch) (\ stopListening -> stopListening) $ \ _ -> do+ action where+ dispatch :: FSNotify.Event -> IO ()+ dispatch = \ case+ FSNotify.Added file _ _ -> emit $ FileEvent FileAdded file+ FSNotify.Modified file _ _ -> emit $ FileEvent FileModified file+ FSNotify.ModifiedAttributes file _ _ -> emit $ FileEvent FileModified file+ FSNotify.Removed file _ _ -> emit $ FileEvent FileRemoved file+ FSNotify.WatchedDirectoryRemoved _file _ _ -> pass+ FSNotify.CloseWrite file _ _ -> emit $ FileEvent FileModified file+ FSNotify.Unknown file _ _ _ -> emit $ FileEvent FileModified file++ emit :: EventQueue.Event -> IO () 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)+ isInteresting :: FSNotify.Event -> Bool+ isInteresting = (&&) <$> isFile <*> not . isBoring . FSNotify.eventPath -watchInput :: EventQueue -> IO ()-watchInput queue = void . forkIO $ do- input <- getContents- forM_ (lines input) $ \_ -> do- emitEvent queue TriggerAll- emitEvent queue Done+ isFile :: FSNotify.Event -> Bool+ isFile = FSNotify.eventIsDirectory >>> (== FSNotify.IsFile) +data Mode = Lenient | Strict+ run :: FilePath -> [String] -> IO () run startupFile args = do+ runArgs@RunArgs{dir, lastOutput, queue} <- defaultRunArgs startupFile+ HTTP.withServer dir (readMVar lastOutput) $ do+ watchFiles dir queue $ do+ mode <- newIORef Lenient+ Input.watch stdin (dispatch mode queue) (emitEvent queue Done)+ runWith runArgs {args}+ where+ dispatch :: IORef Mode -> EventQueue -> Char -> IO ()+ dispatch mode queue = \ case+ '\n' -> emitEvent queue TriggerAll+ 'w' -> do+ modifyIORef mode toggle+ readIORef mode >>= \ case+ Lenient -> emitEvent queue (RestartWith ["-Wdefault"])+ Strict -> emitEvent queue (RestartWith ["-Wall"])+ 'q' -> emitEvent queue Done+ _ -> pass++ toggle :: Mode -> Mode+ toggle = \ case+ Lenient -> Strict+ Strict -> Lenient++defaultRunArgs :: FilePath -> IO RunArgs+defaultRunArgs startupFile = 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+ lastOutput <- newMVar (Trigger.Success, "")+ return RunArgs {+ ignoreConfig = False+ , dir = ""+ , args = []+ , lastOutput = lastOutput+ , queue = queue+ , sessionConfig = defaultSessionConfig startupFile+ , withSession = Session.withSession+ } - go = do- status <- withSession startupFile args $ \ session -> do- let- triggerAction = saveOutput (trigger session)- triggerAllAction = saveOutput (triggerAll session)- triggerAction- processQueue queue triggerAllAction triggerAction- case status of- Reload -> go- Terminate -> return ()- go+data RunArgs = RunArgs {+ ignoreConfig :: Bool+, dir :: FilePath+, args :: [String]+, lastOutput :: MVar (Result, String)+, queue :: EventQueue+, sessionConfig :: Session.Config+, withSession :: forall r. Session.Config -> [String] -> (Session.Session -> IO r) -> IO r+} +runWith :: RunArgs -> IO ()+runWith RunArgs {..} = do+ config <- case ignoreConfig of+ False -> loadConfig+ True -> return defaultConfig+ cleanup <- newIORef pass+ let+ runCleanupAction :: IO ()+ runCleanupAction = join $ atomicModifyIORef' cleanup $ (,) pass++ addCleanupAction :: IO () -> IO ()+ addCleanupAction cleanupAction = atomicModifyIORef' cleanup $ \ action -> (action >> cleanupAction, ())++ saveOutput :: IO (Trigger.Result, String) -> IO ()+ saveOutput action = do+ runCleanupAction+ result <- modifyMVar lastOutput $ \ _ -> (id &&& id) <$> action+ case result of+ (HookFailed, _output) -> pass+ (Failure, output) -> config.senseiHooksOnFailure >>= \ case+ HookSuccess -> pager output >>= addCleanupAction+ HookFailure message -> hPutStrLn stderr message+ (Success, _output) -> config.senseiHooksOnSuccess >>= \ case+ HookSuccess -> pass+ HookFailure message -> hPutStrLn stderr message++ hooks :: Hooks+ hooks = Hooks {+ beforeReload = config.senseiHooksBeforeReload+ , afterReload = config.senseiHooksAfterReload+ }++ go extraArgs = do+ status <- withSession sessionConfig (extraArgs <> args) $ \ session -> do+ let+ triggerAction = saveOutput (trigger session hooks)+ triggerAllAction = saveOutput (triggerAll session hooks)+ triggerAction+ processQueue runCleanupAction (sessionConfig.configEcho . encodeUtf8) dir queue triggerAllAction triggerAction+ case status of+ Restart mExtraArgs -> go (fromMaybe extraArgs mExtraArgs)+ Terminate -> return ()+ go []+ runWeb :: FilePath -> [String] -> IO () runWeb startupFile args = do- withSession startupFile args $ \session -> do- _ <- trigger session+ Session.withSession (defaultSessionConfig startupFile) args $ \session -> do+ _ <- trigger session defaultHooks lock <- newMVar ()- HTTP.withServer (withMVar lock $ \() -> trigger session) $ do+ HTTP.withServer "" (withMVar lock $ \() -> trigger session defaultHooks) $ do waitForever -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:"- putStrLn ""- putStrLn " chmod go-w .ghci ."- putStrLn ""- exitFailure- Session.withSession config args action- where- config :: Config- config = Config {- configIgnoreDotGhci = False- , configVerbose = True- , configStartupFile = startupFile- }+defaultSessionConfig :: FilePath -> Session.Config+defaultSessionConfig startupFile = Session.Config {+ configIgnoreDotGhci = False+, configStartupFile = startupFile+, configWorkingDirectory = Nothing+, configEcho = \ string -> ByteString.putStr string >> hFlush stdout+}
src/Session.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} module Session ( Config(..) , Session(..)+, echo , withSession , reload @@ -16,7 +16,6 @@ #ifdef TEST , runSpec , hasSpec-, hspecFailureEnvName , hasHspecCommandSignature , hspecCommand , parseSummary@@ -32,32 +31,31 @@ import Util import Options -hspecFailureEnvName :: String-hspecFailureEnvName = "HSPEC_FAILURES"- data Session = Session {- sessionInterpreter :: Interpreter-, sessionHspecArgs :: [String]-, sessionHspecPreviousSummary :: IORef (Maybe Summary)+ interpreter :: Interpreter+, hspecArgs :: [String]+, hspecPreviousSummaryRef :: IORef (Maybe Summary) } +echo :: Session -> String -> IO ()+echo session = session.interpreter.echo . encodeUtf8+ resetSummary :: Session -> IO ()-resetSummary Session{..} = writeIORef sessionHspecPreviousSummary (Just $ Summary 0 0)+resetSummary session = writeIORef session.hspecPreviousSummaryRef (Just $ Summary 0 0) -hspecPreviousSummary :: Session -> IO (Maybe Summary)-hspecPreviousSummary Session{..} = readIORef sessionHspecPreviousSummary+hspecPreviousSummary :: MonadIO m => Session -> m (Maybe Summary)+hspecPreviousSummary session = liftIO $ readIORef session.hspecPreviousSummaryRef 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{..} = evalVerbose sessionInterpreter ":reload"+reload :: MonadIO m => Session -> m String+reload session = liftIO $ evalVerbose session.interpreter ":reload" data Summary = Summary { summaryExamples :: Int@@ -67,15 +65,21 @@ hspecCommand :: String hspecCommand = "Test.Hspec.Runner.hspecResult spec" +hspecCoreCommand :: String+hspecCoreCommand = "Test.Hspec.Core.Runner.hspecResult spec"+ hspecMetaCommand :: String hspecMetaCommand = "Test.Hspec.Meta.hspecResult spec" getRunSpec :: Session -> IO (Maybe (IO String))-getRunSpec session = do- r <- getRunSpecWith hspecCommand session- case r of- Just _ -> return r- Nothing -> getRunSpecWith hspecMetaCommand session+getRunSpec session = go [hspecCommand, hspecCoreCommand, hspecMetaCommand]+ where+ go = \ case+ [] -> return Nothing+ command : commands -> do+ getRunSpecWith command session >>= \ case+ r@Just{} -> return r+ Nothing -> go commands getRunSpecWith :: String -> Session -> IO (Maybe (IO String)) getRunSpecWith command session = do@@ -85,7 +89,7 @@ else return Nothing hasSpec :: String -> Session -> IO Bool-hasSpec command Session{..} = hasHspecCommandSignature command <$> eval sessionInterpreter (":type " ++ command)+hasSpec command session = hasHspecCommandSignature command <$> eval session.interpreter (":type " ++ command) hasHspecCommandSignature :: String -> String -> Bool hasHspecCommandSignature command = any match . lines . normalizeTypeSignatures@@ -93,18 +97,18 @@ match line = (command ++ " :: IO ") `isPrefixOf` line && "Summary" `isSuffixOf` line runSpec :: String -> Session -> IO String-runSpec command session@Session{..} = do+runSpec command session = do failedPreviously <- isFailure <$> hspecPreviousSummary session- let args = "--color" : (if failedPreviously then addRerun else id) sessionHspecArgs- r <- evalVerbose sessionInterpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command- writeIORef sessionHspecPreviousSummary (parseSummary r)+ 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) return r where addRerun :: [String] -> [String] addRerun args = "--rerun" : args isFailure :: Maybe Summary -> Bool-isFailure = maybe True ((/= 0) . summaryFailures)+isFailure = maybe True ((/= 0) . (.summaryFailures)) isSuccess :: Maybe Summary -> Bool isSuccess = not . isFailure
src/Trigger.hs view
@@ -1,23 +1,52 @@ {-# LANGUAGE CPP #-} module Trigger (- trigger+ Hook+, HookResult(..)+, Hooks(..)+, defaultHooks+, Result(..)+, trigger , triggerAll #ifdef TEST , reloadedSuccessfully+, removeProgress #endif ) where import Imports +#if MIN_VERSION_mtl(2,3,1)+import Control.Monad.Trans.Writer.CPS (runWriterT)+import Control.Monad.Writer.CPS hiding (pass)+#else+import Control.Monad.Writer.Strict hiding (pass)+#endif +import Control.Monad.Except+ import Util+import Config (Hook, HookResult(..)) import Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary) import qualified Session -triggerAll :: Session -> IO (Bool, String)-triggerAll session = do+data Hooks = Hooks {+ beforeReload :: Hook+, afterReload :: Hook+}++defaultHooks :: Hooks+defaultHooks = Hooks {+ beforeReload = return HookSuccess+, afterReload = return HookSuccess+}++data Result = HookFailed | Failure | Success+ deriving (Eq, Show)++triggerAll :: Session -> Hooks -> IO (Result, String)+triggerAll session hooks = do resetSummary session- trigger session+ trigger session hooks reloadedSuccessfully :: String -> Bool reloadedSuccessfully = any success . lines@@ -30,34 +59,62 @@ Just xs -> "modules loaded: " `isPrefixOf` xs Nothing -> False -trigger :: Session -> IO (Bool, String)-trigger session = do- xs <- Session.reload session- fmap (xs ++) <$> if reloadedSuccessfully xs- then do- withColor Green $ putStrLn "RELOADING SUCCEEDED"- hspec- else do- withColor Red $ putStrLn "RELOADING FAILED"- return (False, "")+removeProgress :: String -> String+removeProgress xs = case break (== '\r') xs of+ (_, "") -> xs+ (ys, _ : zs) -> dropLastLine ys ++ removeProgress zs where- hspec :: IO (Bool, String)- hspec = do- mRun <- Session.getRunSpec session- case mRun of- Just run -> runSpecs run- Nothing -> return (True, "")+ dropLastLine :: String -> String+ dropLastLine = reverse . dropWhile (/= '\n') . reverse - runSpecs :: IO String -> IO (Bool, String)- runSpecs run = do+type Trigger = ExceptT Result (WriterT String IO)++trigger :: Session -> Hooks -> IO (Result, String)+trigger session hooks = runWriterT (runExceptT go) >>= \ case+ (Left result, output) -> return (result, output)+ (Right (), output) -> return (Success, output)+ where+ go :: Trigger ()+ go = do+ runHook hooks.beforeReload+ output <- Session.reload session+ tell output+ case reloadedSuccessfully output of+ False -> do+ echo $ withColor Red "RELOADING FAILED" <> "\n"+ abort+ True -> do+ echo $ withColor Green "RELOADING SUCCEEDED" <> "\n"++ runHook hooks.afterReload+ getRunSpec >>= \ case+ Just hspec -> rerunAllOnSuccess hspec+ Nothing -> pass++ abort :: Trigger a+ abort = throwError Failure++ rerunAllOnSuccess :: Trigger () -> Trigger ()+ rerunAllOnSuccess hspec = do failedPreviously <- isFailure <$> hspecPreviousSummary session- (success, xs) <- runSpec run- fmap (xs ++) <$> if success && failedPreviously- then runSpec run- else return (success, "")+ hspec+ when failedPreviously hspec - runSpec :: IO a -> IO (Bool, a)- runSpec run = do- xs <- run- success <- isSuccess <$> hspecPreviousSummary session- return (success, xs)+ getRunSpec :: MonadIO m => m (Maybe (Trigger ()))+ getRunSpec = liftIO $ fmap runSpec <$> Session.getRunSpec session++ runSpec :: IO String -> Trigger ()+ runSpec hspec = do+ liftIO hspec >>= tell . removeProgress+ result <- hspecPreviousSummary session+ unless (isSuccess result) abort++ runHook :: Hook -> Trigger ()+ runHook hook = liftIO hook >>= \ case+ HookSuccess -> pass+ HookFailure message -> echo message >> throwError HookFailed++ echo :: String -> Trigger ()+ echo message = do+ tell message+ liftIO $ Session.echo session message
src/Util.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE CPP, OverloadedStrings, LambdaCase, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE CPP #-} module Util ( Color(..) , withColor , withInfoColor+, encodeUtf8 , isBoring , filterGitIgnoredFiles , normalizeTypeSignatures-, dotGhciWritableByOthers+, isWritableByOthers #ifdef TEST , filterGitIgnoredFiles_@@ -18,44 +19,47 @@ import Imports import System.Console.ANSI-import System.FilePath import System.Process import System.Posix.Files import System.Posix.Types import qualified Data.Text as T+import qualified Data.Text.Encoding as T -withInfoColor :: IO a -> IO a+withInfoColor :: String -> String withInfoColor = withColor Magenta -withColor :: Color -> IO a -> IO a-withColor c = bracket_ set reset+withColor :: Color -> String -> String+withColor c string = set <> string <> reset where- set = setSGR [SetColor Foreground Dull c]- reset = setSGR []+ set = setSGRCode [SetColor Foreground Dull c]+ reset = setSGRCode [] +encodeUtf8 :: String -> ByteString+encodeUtf8 = T.encodeUtf8 . T.pack+ isBoring :: FilePath -> Bool isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p where dirs = splitDirectories p isEmacsAutoSave = isPrefixOf ".#" . takeFileName -filterGitIgnoredFiles :: [FilePath] -> IO [FilePath]-filterGitIgnoredFiles files = do- (feedback, ignoredFiles) <- filterGitIgnoredFiles_ files+filterGitIgnoredFiles :: (String -> IO ()) -> FilePath -> [FilePath] -> IO [FilePath]+filterGitIgnoredFiles echo dir files = do+ (feedback, ignoredFiles) <- filterGitIgnoredFiles_ dir files printFeedback feedback- return $ ignoredFiles+ return ignoredFiles where printFeedback :: Feedback -> IO ()- printFeedback = mapM_ $ \ (color, err) -> withColor color $ putStrLn ('\n' : err)+ printFeedback = mapM_ $ \ (color, err) -> echo ('\n' : withColor color err <> "\n") type Feedback = Maybe (Color, String) -filterGitIgnoredFiles_ :: [FilePath] -> IO (Feedback, [FilePath])-filterGitIgnoredFiles_ files = fmap (files \\) <$> gitCheckIgnore files+filterGitIgnoredFiles_ :: FilePath -> [FilePath] -> IO (Feedback, [FilePath])+filterGitIgnoredFiles_ dir files = fmap (files \\) <$> gitCheckIgnore dir files -gitCheckIgnore :: [FilePath] -> IO (Feedback, [FilePath])-gitCheckIgnore files = do- (_, ignoredFiles, err) <- readProcessWithExitCode "git" ["check-ignore", "--stdin", "-z"] $ join_ files+gitCheckIgnore :: FilePath -> [FilePath] -> IO (Feedback, [FilePath])+gitCheckIgnore dir files = do+ (_, ignoredFiles, err) <- readProcessWithExitCode "git" ["-C", dir, "check-ignore", "--stdin", "-z"] $ join_ files return (gitCheckIgnoreFeedback err, split ignoredFiles) where join_ = intercalate "\0"@@ -82,12 +86,12 @@ '\8594' -> "->" _ -> [c] -dotGhciWritableByOthers :: IO Bool-dotGhciWritableByOthers = do- exists <- fileExist ".ghci"+isWritableByOthers :: FilePath -> IO Bool+isWritableByOthers name = do+ exists <- fileExist name if exists then do- mode <- fileMode <$> getFileStatus ".ghci"- dirMode <- fileMode <$> getFileStatus "."+ mode <- fileMode <$> getFileStatus name+ dirMode <- fileMode <$> getFileStatus (takeDirectory name) return (writableByOthers mode || writableByOthers dirMode) else return False
test/ClientSpec.hs view
@@ -1,25 +1,25 @@-{-# LANGUAGE OverloadedStrings #-} module ClientSpec (spec) where import Helper import HTTP import Client+import qualified Trigger 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")+ withTempDirectory $ \ dir -> do+ withServer dir (return (Trigger.Success, "hello")) $ do+ client dir `shouldReturn` (True, "hello") it "indicates failure" $ do- inTempDirectory $ do- withServer (return (False, "hello")) $ do- client `shouldReturn` (False, "hello")+ withTempDirectory $ \ dir -> do+ withServer dir (return (Trigger.Failure, "hello")) $ do+ client dir `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")+ withTempDirectory $ \ dir -> do+ client dir `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n")
+ test/ConfigSpec.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module ConfigSpec (spec) where++import Helper+import Data.Aeson+import Data.Yaml.TH+import Data.ByteString.Lazy qualified as LB++import Config++spec :: Spec+spec = do+ describe "readConfigFilesFrom" $ do+ it "reads config values from ./sensei.yaml" $ do+ withTempDirectory $ \ dir -> do+ let+ global = dir </> "global.yaml"+ local = dir </> "local.yaml"+ LB.writeFile local $ encode [yamlQQ|+ before-reload: local-before-reload+ on-success: local-on-success+ |]+ readConfigFilesFrom global local `shouldReturn` Right mempty {+ beforeReload = Just "local-before-reload"+ , onSuccess = Just "local-on-success"+ }++ it "reads config values from ~/.config/sensei/sensei.yaml" $ do+ withTempDirectory $ \ dir -> do+ let+ global = dir </> "global.yaml"+ local = dir </> "local.yaml"+ LB.writeFile global $ encode [yamlQQ|+ on-failure: global-on-failure+ on-success: global-on-success+ |]+ readConfigFilesFrom global local `shouldReturn` Right mempty {+ onFailure = Just "global-on-failure"+ , onSuccess = Just "global-on-success"+ }++ context "with both ~/.config/sensei/sensei.yaml and ./sensei.yaml" $ do+ it "gives fields from ./sensei.yaml precedence" $ do+ withTempDirectory $ \ dir -> do+ let+ global = dir </> "global.yaml"+ local = dir </> "local.yaml"+ LB.writeFile global $ encode [yamlQQ|+ on-failure: global-on-failure+ on-success: global-on-success+ |]+ LB.writeFile local $ encode [yamlQQ|+ before-reload: local-before-reload+ on-success: local-on-success+ |]+ readConfigFilesFrom global local `shouldReturn` Right mempty {+ beforeReload = Just "local-before-reload"+ , onFailure = Just "global-on-failure"+ , onSuccess = Just "local-on-success"+ }++ context "with unknown fields" $ do+ it "returns an error" $ do+ withTempDirectory $ \ dir -> do+ let+ global = dir </> "global.yaml"+ local = dir </> "local.yaml"+ LB.writeFile local $ encode [yamlQQ|+ some-field: some-value+ |]+ readConfigFilesFrom global local `shouldReturn` Left "Aeson exception:\nError in $: parsing Config.ConfigFile(ConfigFile) failed, unknown fields: [\"some-field\"]"++ describe "ConfigFile" $ do+ it "deserializes from yaml" $ do+ fromJSON [yamlQQ|+ after-reload: foo bar baz+ before-reload: blah+ on-success: snafu+ on-failure: failure+ |] `shouldBe` Success ConfigFile {+ afterReload = Just "foo bar baz"+ , beforeReload = Just "blah"+ , onSuccess = Just "snafu"+ , onFailure = Just "failure"+ }++ it "supports null" $ do+ fromJSON [yamlQQ|+ after-reload: null+ before-reload: blah+ on-success: finally+ on-failure: failure+ |] `shouldBe` Success ConfigFile {+ afterReload = Nothing+ , beforeReload = Just "blah"+ , onSuccess = Just "finally"+ , onFailure = Just "failure"+ }++ it "supports missing fields" $ do+ fromJSON [yamlQQ|+ after-reload: blah+ |] `shouldBe` Success ConfigFile {+ afterReload = Just "blah"+ , beforeReload = Nothing+ , onSuccess = Nothing+ , onFailure = Nothing+ }++ it "accepts an emty config" $ do+ fromJSON @ConfigFile [yamlQQ|+ |] `shouldBe` Success mempty
test/EventQueueSpec.hs view
@@ -1,58 +1,95 @@ module EventQueueSpec (spec) where import Helper+import qualified System.Info +import Run (watchFiles)+ import EventQueue -withGitRepository :: IO a -> IO a-withGitRepository action = inTempDirectory (readProcess "git" ["init"] "" >> action)+withGitRepository :: (FilePath -> IO a) -> IO a+withGitRepository action = withTempDirectory $ \ dir -> do+ readProcess "git" ["-C", dir, "init"] "" >> action dir spec :: Spec spec = do+ describe "processQueue" $ do+ context "when a spec is added" $ do+ it "restarts" $ do+ when (System.Info.os == "darwin") pending+ withTempDirectory $ \ dir -> do+ queue <- newQueue+ watchFiles dir queue $ do+ threadDelay 100_000+ touch $ dir </> "FooSpec.hs"+ timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing)++ context "when a spec is removed" $ do+ it "restarts" $ do+ withTempDirectory $ \ dir -> do+ let file = dir </> "FooSpec.hs"+ touch file+ queue <- newQueue+ watchFiles dir queue $ do+ threadDelay 100_000+ removeFile file+ timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing)++ context "when .ghci is modified" $ do+ it "restarts" $ do+ withTempDirectory $ \ dir -> do+ let file = dir </> ".ghci"+ touch file+ queue <- newQueue+ watchFiles dir queue $ do+ threadDelay 100_000+ touch file+ timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing)+ describe "processEvents" $ do- around_ withGitRepository $ do+ around withGitRepository $ do context "with FileEvent" $ do- it "returns TriggerAction" $ do- processEvents [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"]+ it "returns TriggerAction" $ \ dir -> do+ processEvents silent dir [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] context "with git ignored files" $ do- it "returns NoneAction" $ do- writeFile ".gitignore" "test/FooSpec.hs"- processEvents [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` NoneAction+ it "returns NoneAction" $ \ dir -> do+ writeFile (dir </> ".gitignore") "test/FooSpec.hs"+ processEvents silent dir [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` NoneAction context "when a Spec file is added" $ do- it "returns ReloadAction" $ do- processEvents [FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` ReloadAction "test/FooSpec.hs" FileAdded+ it "returns RestartAction" $ \ dir -> do+ processEvents silent dir [FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` RestartAction "test/FooSpec.hs" FileAdded - it "takes precedence over TriggerAll" $ do- processEvents [TriggerAll, FileEvent FileAdded "test/FooSpec.hs", TriggerAll] `shouldReturn` ReloadAction "test/FooSpec.hs" FileAdded+ it "takes precedence over TriggerAll" $ \ dir -> do+ processEvents silent dir [TriggerAll, FileEvent FileAdded "test/FooSpec.hs", TriggerAll] `shouldReturn` RestartAction "test/FooSpec.hs" FileAdded - it "is overruled by Done" $ do- processEvents [Done, FileEvent FileAdded "test/FooSpec.hs", Done] `shouldReturn` DoneAction+ it "is overruled by Done" $ \ dir -> do+ processEvents silent dir [Done, FileEvent FileAdded "test/FooSpec.hs", Done] `shouldReturn` DoneAction context "when a Spec file is removed" $ do- it "returns ReloadAction" $ do- processEvents [FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` ReloadAction "test/FooSpec.hs" FileRemoved+ it "returns RestartAction" $ \ dir -> do+ processEvents silent dir [FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` RestartAction "test/FooSpec.hs" FileRemoved context "when file is first removed and then added" $ do- it "returns TriggerAction" $ do- processEvents [FileEvent FileRemoved "test/FooSpec.hs", FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"]+ it "returns TriggerAction" $ \ dir -> do+ processEvents silent dir [FileEvent FileRemoved "test/FooSpec.hs", FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] context "when file is first added and then removed" $ do- it "returns NoneAction" $ do- processEvents [FileEvent FileAdded "test/FooSpec.hs", FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` NoneAction+ it "returns NoneAction" $ \ dir -> do+ processEvents silent dir [FileEvent FileAdded "test/FooSpec.hs", FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` NoneAction context "with TriggerAll" $ do- it "returns TriggerAllAction" $ do- processEvents [TriggerAll] `shouldReturn` TriggerAllAction+ it "returns TriggerAllAction" $ \ dir -> do+ processEvents silent dir [TriggerAll] `shouldReturn` TriggerAllAction - it "takes precedence over FileEvent" $ do- processEvents [FileEvent FileModified "foo", TriggerAll, FileEvent FileModified "foo"] `shouldReturn` TriggerAllAction+ it "takes precedence over FileEvent" $ \ dir -> do+ processEvents silent dir [FileEvent FileModified "foo", TriggerAll, FileEvent FileModified "foo"] `shouldReturn` TriggerAllAction context "with Done" $ do- it "returns DoneAction" $ do- processEvents [Done] `shouldReturn` DoneAction+ it "returns DoneAction" $ \ dir -> do+ processEvents silent dir [Done] `shouldReturn` DoneAction describe "combineFileEvents" $ do it "combines removed/added to modified" $ do
test/HTTPSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module HTTPSpec (spec) where import Helper@@ -6,14 +5,15 @@ import Test.Hspec.Wai import HTTP+import qualified Trigger spec :: Spec spec = do describe "app" $ do- with (return $ app $ return (True, "hello")) $ do+ with (return $ app $ return (Trigger.Success, "hello")) $ do it "returns 200 on success" $ do get "/" `shouldRespondWith` 200 - with (return $ app $ return (False, "hello")) $ do+ with (return $ app $ return (Trigger.Failure, "hello")) $ do it "return 500 on failure" $ do get "/" `shouldRespondWith` 500
test/Helper.hs view
@@ -1,48 +1,61 @@ module Helper ( module Imports+, silent , ghciConfig-, withSession+, withTempDirectory , withSomeSpec , passingSpec , passingMetaSpec , failingSpec , Status(..) , modulesLoaded++, Color(..)+, withColor++, timeout ) where import Imports -import System.IO.Silently as Imports-import System.Process as Imports (readProcess, callCommand)+import System.Directory as Imports+import System.IO.Temp (withSystemTempDirectory)+import System.Process as Imports (readProcess, callProcess, callCommand) import Test.Hspec as Imports-import Test.Mockery.Directory as Imports import Test.Hspec.Contrib.Mocks.V1 as Imports+import Test.Mockery.Directory as Imports (touch) +import System.Environment+import qualified System.Timeout+ import Run ()-import qualified Session-import Session (Session)+import Util import Language.Haskell.GhciWrapper (Config(..)) -startupFile :: FilePath-startupFile = "startup.ghci"+timeout :: IO a -> IO (Maybe a)+timeout action = lookupEnv "CI" >>= \ case+ Nothing -> System.Timeout.timeout 5_000_000 action+ Just _ -> System.Timeout.timeout 30_000_000 action +silent :: a -> IO ()+silent _ = pass+ ghciConfig :: Config ghciConfig = Config { configIgnoreDotGhci = True-, configVerbose = False-, configStartupFile = startupFile+, configStartupFile = "startup.ghci"+, configWorkingDirectory = Nothing+, configEcho = silent } -withSession :: [String] -> (Session -> IO a) -> IO a-withSession = Session.withSession ghciConfig+withTempDirectory :: (FilePath -> IO a) -> IO a+withTempDirectory = withSystemTempDirectory "hspec" -withSomeSpec :: IO a -> IO a-withSomeSpec action = do- startup <- readFile startupFile- inTempDirectory $ do- writeFile startupFile startup- writeFile "Spec.hs" passingSpec- action+withSomeSpec :: (FilePath -> IO a) -> IO a+withSomeSpec action = withTempDirectory $ \ dir -> do+ let name = dir </> "Spec.hs"+ writeFile name passingSpec+ action name passingSpec :: String passingSpec = unlines [
test/Language/Haskell/GhciWrapperSpec.hs view
@@ -2,8 +2,9 @@ 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(..)) import qualified Language.Haskell.GhciWrapper as Interpreter main :: IO ()@@ -20,16 +21,50 @@ 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."+ result <- withSpy $ \ spy -> do+ Interpreter.withInterpreter ghciConfig {configEcho = spy} [] $ \ _ghci -> do+ pass+ last (ByteString.lines $ mconcat result) `shouldBe` "Leaving GHCi." + context "when .ghci is writable by others" $ do+ let+ with :: FilePath -> Config -> IO String+ with dir config = do+ let dotGhci = dir </> ".ghci"+ writeFile dotGhci ""+ callProcess "chmod" ["go+w", dotGhci]+ Interpreter.withInterpreter config { configWorkingDirectory = Just dir } [] $ \ ghci -> Interpreter.eval ghci "23"++ context "when configIgnoreDotGhci is False" $ do+ it "terminates with an error message" $ do+ withTempDirectory $ \ dir -> do+ let dotGhci = dir </> ".ghci"+ with dir ghciConfig { configIgnoreDotGhci = False } `shouldThrow` (== (ErrorCall . unlines) [+ dotGhci <> " is writable by others, you can fix this with:"+ , ""+ , " chmod go-w " <> dotGhci <> " ."+ , ""+ ])++ context "when configIgnoreDotGhci is True" $ do+ it "does not terminate" $ do+ withTempDirectory $ \ dir -> do+ with dir ghciConfig { configIgnoreDotGhci = True } `shouldReturn` "23\n"+ 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")+ it "echos result" $ do+ fmap mconcat . withSpy $ \ spy -> do+ withInterpreter [] $ \ ghci -> do+ Interpreter.evalVerbose ghci {echo = spy} "23" `shouldReturn` "23\n"+ `shouldReturn` "23\n" describe "eval" $ do+ it "does not echo result" $ do+ fmap mconcat . withSpy $ \ spy -> do+ withInterpreter [] $ \ ghci -> do+ Interpreter.eval ghci {echo = spy} "23" `shouldReturn` "23\n"+ `shouldReturn` ""+ it "shows literals" $ withGhci $ \ ghci -> do ghci "23" `shouldReturn` "23\n"
test/OptionsSpec.hs view
@@ -10,8 +10,18 @@ spec :: Spec spec = do describe "splitArgs" $ do- it "returns longest matching list of Hspec arguments from end of given list" $ do+ it "returns longest matching list of Hspec options 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+ it "assumes everything after the last '--' to be Hspec options" $ do splitArgs ["foo", "bar", "--", "foo", "baz"] `shouldBe` (["foo", "bar"], ["foo", "baz"])++ context "with -p" $ do+ it "recognizes -p as an Hspec option" $ do+ splitArgs ["-p"] `shouldBe` ([], ["-p"])++ it "recognizes -pN as an Hspec option" $ do+ splitArgs ["-p20"] `shouldBe` ([], ["-p20"])++ it "recognizes -packageNAME as a GHC option" $ do+ splitArgs ["-packagebase"] `shouldBe` (["-packagebase"], [])
+ test/PagerSpec.hs view
@@ -0,0 +1,51 @@+module PagerSpec (spec) where++import Helper++import System.IO+import System.Process hiding (createPipe)++import Pager++spec :: Spec+spec = do+ describe "matchOptions" $ do+ it "contains --incsearch" $ do+ -- The `--incsearch` flag changes the behavior of `--pattern` in subtle+ -- ways. A user might have `--incsearch` enabled globally. To ensure+ -- consistent behavior across environments we always enable+ -- `--incsearch`.+ matchOptions `shouldContain` ["--incsearch"]++ describe "pagerWith" $ do+ it "pipes the provided input into a pager" $ do+ (readEnd, writeEnd) <- createPipe+ let+ process :: CreateProcess+ process = (proc "cat" []) { std_out = UseHandle writeEnd }++ input :: String+ input = "foo"++ bracket (pagerWith process input) id $ \ _ -> do+ hGetContents readEnd `shouldReturn` input++ it "can be canceled" $ do+ let+ process :: CreateProcess+ process = proc "sleep" ["1d"]+ cancel <- pagerWith process "foo"+ timeout cancel `shouldReturn` Just ()++ context "when writing to stdin of the subprocess blocks" $ do+ it "can still be canceled" $ do+ (_, writeEnd) <- createPipe+ let+ process :: CreateProcess+ process = (proc "cat" []) { std_out = UseHandle writeEnd }++ input :: String+ input = cycle "foo\n"++ cancel <- pagerWith process input+ timeout cancel `shouldReturn` Just ()
test/ReadHandleSpec.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-} module ReadHandleSpec (spec) where import Helper import Test.QuickCheck-import qualified Data.ByteString as B+import qualified Data.ByteString as ByteString import ReadHandle @@ -14,7 +12,7 @@ go "" = return [] go xs = do n <- chooseInt size- let (chunk, rest) = B.splitAt n xs+ let (chunk, rest) = ByteString.splitAt n xs (chunk :) <$> go rest fakeHandle :: [ByteString] -> IO ReadHandle@@ -28,13 +26,13 @@ let maxChunkSize = case chunkSizes of SmallChunks -> 4- BigChunks -> B.length input+ BigChunks -> ByteString.length input chunks <- chunkByteString (1, maxChunkSize) input return $ fakeHandle chunks >>= action partialMarker :: ByteString-partialMarker = B.take 5 marker+partialMarker = ByteString.take 5 marker spec :: Spec spec = do
+ test/RunSpec.hs view
@@ -0,0 +1,70 @@+module RunSpec (spec) where++import Helper++import EventQueue++import Language.Haskell.GhciWrapper (Config(..))+import Run hiding (defaultRunArgs)+import qualified Run++defaultRunArgs :: IO RunArgs+defaultRunArgs = do+ args <- Run.defaultRunArgs "startup.ghci"+ return args { ignoreConfig = True, sessionConfig = args.sessionConfig { configEcho = silent } }++spec :: Spec+spec = do+ describe "runWith" $ do+ context "on Done" $ do+ it "terminates" $ do+ runArgs <- defaultRunArgs+ emitEvent runArgs.queue Done+ timeout (runWith runArgs) `shouldReturn` Just ()++ context "on RestartWith" $ do+ it "restarts the session with the given extra arguments" $ do+ withSpy $ \ spy -> do+ RunArgs{..} <- defaultRunArgs+ let+ runArgs = RunArgs {+ withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ spy sessionArgs+ action session <* emitEvent runArgs.queue Done+ , ..+ }+ emitEvent runArgs.queue (RestartWith ["-Wall"])+ timeout (runWith runArgs) `shouldReturn` Just ()+ `shouldReturn` [[], ["-Wall"]]++ context "with multiple occurrences of RestartWith" $ do+ it "gives the last occurrence precedence" $ do+ withSpy $ \ spy -> do+ RunArgs{..} <- defaultRunArgs+ let+ runArgs = RunArgs {+ withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ spy sessionArgs+ action session <* emitEvent runArgs.queue Done+ , ..+ }+ emitEvent runArgs.queue (RestartWith ["-Wall"])+ emitEvent runArgs.queue (RestartWith ["-Wdefault"])+ timeout (runWith runArgs) `shouldReturn` Just ()+ `shouldReturn` [[], ["-Wdefault"]]++ context "after a restart without arguments" $ do+ it "remembers the last seen extra arguments" $ do+ nextEvent <- stubAction [RestartWith ["-Wall"], FileEvent FileModified ".ghci", Done]+ withSpy $ \ spy -> do+ RunArgs{..} <- defaultRunArgs+ let+ runArgs = RunArgs {+ withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ spy sessionArgs+ nextEvent >>= emitEvent runArgs.queue+ action session+ , ..+ }+ timeout (runWith runArgs) `shouldReturn` Just ()+ `shouldReturn` [[], ["-Wall"], ["-Wall"]]
test/SessionSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} module SessionSpec (spec) where import Helper@@ -7,45 +6,53 @@ import Language.Haskell.GhciWrapper (eval) import qualified Session-import Session (Config(..), Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary, hspecCommand)+import Session hiding (withSession, runSpec) +withSession :: [String] -> (Session -> IO a) -> IO a+withSession = Session.withSession ghciConfig+ spec :: Spec spec = do describe "withSession" $ do it "unsets HSPEC_FAILURES" $ do- setEnv hspecFailureEnvName "foo" True+ setEnv "HSPEC_FAILURES" "foo" True withSession [] $ \ Session{..} -> do- eval sessionInterpreter ("System.Environment.lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n"+ eval interpreter "System.Environment.lookupEnv \"HSPEC_FAILURES\"" `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"+ withTempDirectory $ \ dir -> do+ let+ config = ghciConfig {+ configIgnoreDotGhci = False+ , configWorkingDirectory = Just dir+ }+ writeFile (dir </> ".ghci") ":set +t +s"+ Session.withSession config [] $ \ Session{..} -> do+ eval interpreter "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"+ eval interpreter "23 :: Int" `shouldReturn` "23\n" describe "reload" $ do it "reloads" $ do withSession [] $ \session -> do- silence (Session.reload session) `shouldReturn` (modulesLoaded Ok [] ++ "\n")+ Session.reload session `shouldReturn` (modulesLoaded Ok [] ++ "\n") - describe "hasSpec" $ around_ withSomeSpec $ do+ describe "hasSpec" $ around withSomeSpec $ do context "when module contains spec" $ do- it "returns True" $ do- withSession ["Spec.hs"] $ \session -> do- _ <- silence (Session.reload session)+ it "returns True" $ \ name -> do+ withSession [name] $ \session -> do+ _ <- Session.reload session Session.hasSpec hspecCommand 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)+ it "returns False" $ \ name -> do+ withSession [name] $ \session -> do+ writeFile name "module Main where"+ _ <- Session.reload session Session.hasSpec hspecCommand session `shouldReturn` False describe "hasHspecCommandSignature" $ do@@ -70,16 +77,16 @@ it "returns False" $ do Session.hasHspecCommandSignature hspecCommand "foo" `shouldBe` False - describe "runSpec" $ around_ withSomeSpec $ do+ describe "runSpec" $ around withSomeSpec $ do let runSpec = Session.runSpec hspecCommand- it "stores summary of spec run" $ do- withSession ["Spec.hs"] $ \session -> do- _ <- silence (runSpec session >> runSpec session)+ it "stores summary of spec run" $ \ name -> do+ withSession [name] $ \session -> do+ _ <- runSpec 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 (runSpec session >> runSpec session)+ it "accepts Hspec args" $ \ name -> do+ withSession [name, "--no-color", "-m", "foo"] $ \session -> do+ _ <- runSpec session >> runSpec session hspecPreviousSummary session `shouldReturn` Just (Summary 1 0) describe "parseSummary" $ do
+ test/SpecHook.hs view
@@ -0,0 +1,7 @@+module SpecHook where++import Test.Hspec+import GHC.Conc++hook :: Spec -> Spec+hook spec = runIO (getNumProcessors >>= setNumCapabilities) >> parallel spec
test/TriggerSpec.hs view
@@ -3,36 +3,71 @@ import Helper -import Trigger+import qualified Session+import Session (Session)+import Language.Haskell.GhciWrapper (Config(..)) +import Trigger hiding (trigger, triggerAll)+import qualified Trigger+ normalize :: String -> [String]-normalize = normalizeErrors . normalizeTiming . normalizeSeed . lines . stripAnsiColors+normalize = normalizeTiming . lines where normalizeTiming :: [String] -> [String]- normalizeTiming = mkNormalize "Finished in "-- normalizeSeed :: [String] -> [String]- normalizeSeed = mkNormalize "Randomized with seed "+ normalizeTiming = normalizeLine "Finished in " - mkNormalize :: String -> [String] -> [String]- mkNormalize message = map f+ normalizeLine :: String -> [String] -> [String]+ normalizeLine message = map f where f line | message `isPrefixOf` line = message ++ "..." | otherwise = line - normalizeErrors :: [String] -> [String]- normalizeErrors xs = case xs of- y : ys | "Spec.hs:" `isPrefixOf` y -> "Spec.hs:..." : normalizeErrors ys- y : ys -> y : normalizeErrors ys- [] -> []+withSession :: FilePath -> [String] -> (Session -> IO a) -> IO a+withSession specPath args = do+ Session.withSession ghciConfig {configWorkingDirectory = Just dir} $+ "-fhide-source-paths"+ : "-fno-diagnostics-show-caret"+ : "-fdiagnostics-color=never"+ : file+ : args+ ++ ["--no-color", "--seed=0"]+ where+ (dir, file) = splitFileName specPath - stripAnsiColors xs = case xs of- '\ESC' : '[' : ';' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs- '\ESC' : '[' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs- y : ys -> y : stripAnsiColors ys- [] -> []+trigger :: Session -> IO (Result, [String])+trigger session = triggerWithHooks session defaultHooks +triggerWithHooks :: Session -> Hooks -> IO (Result, [String])+triggerWithHooks session hooks = fmap normalize <$> Trigger.trigger session hooks++triggerAll :: Session -> IO (Result, [String])+triggerAll session = fmap normalize <$> Trigger.triggerAll session defaultHooks++requiresHspecMeta :: IO () -> IO ()+requiresHspecMeta action = try action >>= \ case+ Left (ExitFailure 1) -> expectationFailure $ unlines [+ "This tests requires `hspec-meta`, which is not available. To address this run"+ , ""+ , " echo | cabal repl sensei --build-depends hspec-meta"+ , ""+ , "once."+ ]+ Left err -> throwIO err+ Right () -> pass++data HookExecuted = BeforeReloadSucceeded | AfterReloadSucceeded+ deriving (Eq, Show)++withHooks :: (Hooks -> IO ()) -> IO [HookExecuted]+withHooks action = withSpy $ \ spy -> action defaultHooks {+ beforeReload = spy BeforeReloadSucceeded >> return HookSuccess+, afterReload = spy AfterReloadSucceeded >> return HookSuccess+}++failingHook :: Hook+failingHook = return $ HookFailure "hook failed"+ spec :: Spec spec = do describe "reloadedSuccessfully" $ do@@ -58,37 +93,50 @@ it "detects success" $ do reloadedSuccessfully "Ok, four modules loaded." `shouldBe` True - describe "triggerAll" $ around_ withSomeSpec $ do+ describe "removeProgress" $ do+ it "removes transient output" $ do+ (removeProgress . unlines) [+ "foo"+ , "some progress output...\r \rbar"+ , "baz"+ ] `shouldBe` unlines [+ "foo"+ , "bar"+ , "baz"+ ]++ describe "triggerAll" $ 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` [- modulesLoaded Ok ["Spec"]- , ""- , "foo [✔]"- , "bar [✘]"- , ""- , "Failures:"- , ""- , " Spec.hs:8:3: "- , " 1) bar"- , ""- , " To rerun use: --match \"/bar/\""- , ""- , "Randomized with seed ..."- , ""- , "Finished in ..."- , "2 examples, 1 failure"- , "Summary {summaryExamples = 2, summaryFailures = 1}"- ]+ withSomeSpec $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name failingSpec+ (trigger session >> triggerAll session) `shouldReturn` (Failure, [+ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED"+ , ""+ , "foo [✔]"+ , "bar [✘]"+ , ""+ , "Failures:"+ , ""+ , " Spec.hs:8:3: "+ , " 1) bar"+ , ""+ , " To rerun use: --match \"/bar/\" --seed 0"+ , ""+ , "Randomized with seed 0"+ , ""+ , "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, [+ describe "trigger" $ around withSomeSpec $ do+ it "reloads and runs specs" $ \ name -> do+ withSession name [] $ \ session -> do+ trigger session `shouldReturn` (Success, [ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]"@@ -98,32 +146,73 @@ , "Summary {summaryExamples = 2, summaryFailures = 0}" ]) + context "with hooks" $ do+ it "executes hooks" $ \ name -> do+ withHooks $ \ hooks -> do+ withSession name [] $ \ session -> do+ triggerWithHooks session hooks `shouldReturn` (Success, [+ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED"+ , ""+ , "foo [✔]"+ , "bar [✔]"+ , ""+ , "Finished in ..."+ , "2 examples, 0 failures"+ , "Summary {summaryExamples = 2, summaryFailures = 0}"+ ])+ `shouldReturn` [BeforeReloadSucceeded, AfterReloadSucceeded]++ context "when the before-reload hook fails" $ do+ it "cancels the reload cycle" $ \ name -> do+ withHooks $ \ hooks -> do+ withSession name [] $ \ session -> do+ triggerWithHooks session hooks { beforeReload = failingHook } `shouldReturn` (HookFailed, [+ "hook failed"+ ])+ `shouldReturn` []++ context "when the after-reload hook fails" $ do+ it "cancels the reload cycle" $ \ name -> do+ withHooks $ \ hooks -> do+ withSession name [] $ \ session -> do+ triggerWithHooks session hooks { afterReload = failingHook } `shouldReturn` (HookFailed, [+ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED"+ , "hook failed"+ ])+ `shouldReturn` [BeforeReloadSucceeded]+ context "with a module that does not compile" $ do- it "stops after reloading" $ do- withSession ["-fno-diagnostics-show-caret", "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 )"+ it "stops after reloading" $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name (passingSpec ++ "foo = bar")+ (trigger session >> trigger session) `shouldReturn` (Failure, [+ "[1 of 1] Compiling Spec" , ""- , "Spec.hs:..."+#if __GLASGOW_HASKELL__ >= 906+ , "Spec.hs:9:7: error: [GHC-88464] Variable not in scope: bar"+#else+ , "Spec.hs:9:7: error: Variable not in scope: bar"+#endif , modulesLoaded Failed []- ]+ , withColor Red "RELOADING FAILED"+ ]) 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` modulesLoaded Ok ["Spec"]- xs `shouldContain` "2 examples, 1 failure"+ it "indicates failure" $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name failingSpec+ (Failure, xs) <- trigger session+ xs `shouldContain` [modulesLoaded Ok ["Spec"]]+ 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` [+ it "only reruns failing specs" $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name failingSpec+ (trigger session >> trigger session) `shouldReturn` (Failure, [ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED" , "" , "bar [✘]" , ""@@ -132,29 +221,29 @@ , " Spec.hs:8:3: " , " 1) bar" , ""- , " To rerun use: --match \"/bar/\""+ , " To rerun use: --match \"/bar/\" --seed 0" , ""- , "Randomized with seed ..."+ , "Randomized with seed 0" , "" , "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` [+ it "runs all specs" $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name failingSpec+ _ <- trigger session+ writeFile name passingSpec+ trigger session `shouldReturn` (Success, [ #if __GLASGOW_HASKELL__ < 904- "[1 of 1] Compiling Spec ( Spec.hs, interpreted )"+ "[1 of 1] Compiling Spec" #else- "[1 of 1] Compiling Spec ( Spec.hs, interpreted ) [Source file changed]"+ "[1 of 1] Compiling Spec [Source file changed]" #endif , modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED" , "" , "bar [✔]" , ""@@ -168,21 +257,24 @@ , "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 Foo where"- silence (trigger session >> trigger session) `shouldReturn` (True, modulesLoaded Ok ["Foo"] ++ "\n")+ it "only reloads" $ \ name -> do+ withSession name [] $ \ session -> do+ writeFile name "module Foo where"+ (trigger session >> trigger session) `shouldReturn` (Success, [+ modulesLoaded Ok ["Foo"]+ , withColor Green "RELOADING SUCCEEDED"+ ]) context "with an hspec-meta spec" $ do- it "reloads and runs spec" $ do- withSession ["-package hspec-meta", "Spec.hs", "--no-color"] $ \session -> do- writeFile "Spec.hs" passingMetaSpec- result <- silence (trigger session >> trigger session)- fmap normalize result `shouldBe` (True, [+ it "reloads and runs spec" $ \ name -> do+ requiresHspecMeta $ withSession name ["-package hspec-meta"] $ \ session -> do+ writeFile name passingMetaSpec+ (trigger session >> trigger session) `shouldReturn` (Success, [ modulesLoaded Ok ["Spec"]+ , withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]"
test/UtilSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module UtilSpec (spec) where import Helper@@ -7,6 +6,16 @@ import Util +withDotGhci :: (FilePath -> IO a) -> IO a+withDotGhci action = withTempDirectory $ \ dir -> do+ let dotGhci = dir </> ".ghci"+ writeFile dotGhci ""+ chmod "go-w" dotGhci+ action dotGhci++chmod :: String -> FilePath -> IO ()+chmod mode file = callProcess "chmod" [mode, file]+ spec :: Spec spec = do describe "isBoring" $ do@@ -27,15 +36,16 @@ let gitlessFeedback = Just (Cyan, "warning: not a git repository - .gitignore support not available\n") describe "filterGitIgnoredFiles_" $ do- around_ inTempDirectory $ do- it "discards files that are ignored by git" $ do- _ <- readProcess "git" ["init"] ""- writeFile ".gitignore" "foo"- filterGitIgnoredFiles_ ["foo", "bar"] `shouldReturn` (Nothing, ["bar"])+ it "discards files that are ignored by git" $ do+ withTempDirectory $ \ dir -> do+ _ <- readProcess "git" ["-C", dir, "init"] ""+ writeFile (dir </> ".gitignore") "foo"+ filterGitIgnoredFiles_ dir ["foo", "bar"] `shouldReturn` (Nothing, ["bar"]) - context "when used outside of a git repository" $ do- it "returns all files" $ do- filterGitIgnoredFiles_ ["foo", "bar"] `shouldReturn` (gitlessFeedback, ["foo", "bar"])+ context "when used outside of a git repository" $ do+ it "returns all files" $ do+ withTempDirectory $ \ dir -> do+ filterGitIgnoredFiles_ dir ["foo", "bar"] `shouldReturn` (gitlessFeedback, ["foo", "bar"]) describe "gitCheckIgnoreFeedback" $ do context "when git reports no repository" $ do@@ -57,30 +67,34 @@ let err = "fatal: Unable to do such and such" gitCheckIgnoreFeedback err `shouldBe` Just (Red, err) - describe "dotGhciWritableByOthers" $ do- around_ inTempDirectory $ do- before_ (touch ".ghci" >> callCommand "chmod go-w .ghci") $ do- it "returns False" $ do- dotGhciWritableByOthers `shouldReturn` False+ describe "isWritableByOthers" $ do+ it "returns False" $ do+ withDotGhci $ \ dotGhci -> do+ isWritableByOthers dotGhci `shouldReturn` False - context "when writable by group" $ do- it "returns True" $ do- callCommand "chmod g+w .ghci"- dotGhciWritableByOthers `shouldReturn` True+ context "when writable by group" $ do+ it "returns True" $ do+ withDotGhci $ \ dotGhci -> do+ chmod "g+w" dotGhci+ isWritableByOthers dotGhci `shouldReturn` True - context "when writable by others" $ do- it "returns True" $ do- callCommand "chmod o+w .ghci"- dotGhciWritableByOthers `shouldReturn` True+ context "when writable by others" $ do+ it "returns True" $ do+ withDotGhci $ \ dotGhci -> do+ chmod "o+w" dotGhci+ isWritableByOthers dotGhci `shouldReturn` True - context "when directory is writable by group" $ do- it "returns True" $ do- callCommand "chmod g+w ."- dotGhciWritableByOthers `shouldReturn` True+ context "when directory is writable by group" $ do+ it "returns True" $ do+ withDotGhci $ \ dotGhci -> do+ chmod "g+w" (takeDirectory dotGhci)+ isWritableByOthers dotGhci `shouldReturn` True - context "when .ghci does not exist" $ do- it "returns False" $ do- dotGhciWritableByOthers `shouldReturn` False+ context "when .ghci does not exist" $ do+ it "returns False" $ do+ withTempDirectory $ \ dir -> do+ let dotGhci = dir </> ".ghci"+ isWritableByOthers dotGhci `shouldReturn` False describe "writableByOthers" $ do it "returns False for owner" $ do