sandwich 0.3.0.3 → 0.3.0.4
raw patch · 13 files changed
+267/−180 lines, 13 filesdep −haskell-src-exts
Dependencies removed: haskell-src-exts
Files
- CHANGELOG.md +16/−7
- LICENSE +1/−1
- sandwich.cabal +3/−9
- src/Test/Sandwich.hs +9/−4
- src/Test/Sandwich/ArgParsing.hs +3/−0
- src/Test/Sandwich/Internal/Running.hs +3/−1
- src/Test/Sandwich/Interpreters/StartTree.hs +55/−22
- src/Test/Sandwich/ParallelN.hs +24/−18
- src/Test/Sandwich/TH.hs +18/−8
- src/Test/Sandwich/TH/HasMainFunction.hs +0/−59
- src/Test/Sandwich/TestTimer.hs +73/−36
- src/Test/Sandwich/Types/ArgParsing.hs +4/−1
- src/Test/Sandwich/Util/Process.hs +58/−14
CHANGELOG.md view
@@ -1,21 +1,30 @@ # Changelog for sandwich -## Unreleased+## 0.3.0.4 +* Improve display of setup/work/teardown in TUI.+* Ultimately use sigKILL in Sandwich.Util.Process.gracefullyWaitForProcess if sigINT and sigTERM don't work.+* Exit with failure status when tests fail (#103).+* More work on test timing around setup/teardown.+* Decided not to do test timing on introduceWith for now since it can mess up timing frame nesting.+* Generate separate test timer profiles when a parallel node runs.+* Get rid of `haskell-src-exts` usage and mark getSpecWarnOnParseError as deprecated.+* Add gracefullyStopProcess', gracefullyWaitForProcess'.+ ## 0.3.0.3 -* Add 'ContainerOptions' type to `Test.Sandwich.Contexts.Container`-* Improve display of setup/work/teardown in TUI+* Add 'ContainerOptions' type to `Test.Sandwich.Contexts.Container`.+* Improve display of setup/work/teardown in TUI. ## 0.3.0.2 -* Re-fix compatibility for base < 4.14.0.0-* windows: fix Infinity -> maxBound for an Int+* Re-fix compatibility for base < 4.14.0.0.+* windows: fix Infinity -> maxBound for an Int. ## 0.3.0.1 -* Fix openFileExplorerFolderPortable on macOS-* Fix compatibility for base < 4.14.0.0+* Fix openFileExplorerFolderPortable on macOS.+* Fix compatibility for base < 4.14.0.0. ## 0.3.0.0
LICENSE view
@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2024+Copyright Tom McLaughlin (c) 2025 All rights reserved.
sandwich.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: sandwich-version: 0.3.0.3+version: 0.3.0.4 synopsis: Yet another test framework for Haskell description: Please see the <https://codedownio.github.io/sandwich documentation>. category: Testing@@ -13,7 +13,7 @@ bug-reports: https://github.com/codedownio/sandwich/issues author: Tom McLaughlin maintainer: tom@codedown.io-copyright: 2024 Tom McLaughlin+copyright: 2025 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple@@ -86,7 +86,6 @@ Test.Sandwich.Shutdown Test.Sandwich.Signals Test.Sandwich.TestTimer- Test.Sandwich.TH.HasMainFunction Test.Sandwich.TH.ModuleMap Test.Sandwich.Types.ArgParsing Test.Sandwich.Types.General@@ -124,7 +123,6 @@ , exceptions , filepath , free- , haskell-src-exts , microlens , microlens-th , monad-control@@ -187,7 +185,6 @@ , exceptions , filepath , free- , haskell-src-exts , microlens , microlens-th , monad-control@@ -248,7 +245,6 @@ , exceptions , filepath , free- , haskell-src-exts , microlens , microlens-th , monad-control@@ -314,7 +310,6 @@ , exceptions , filepath , free- , haskell-src-exts , microlens , microlens-th , monad-control@@ -381,7 +376,6 @@ , exceptions , filepath , free- , haskell-src-exts , microlens , microlens-th , monad-control
src/Test/Sandwich.hs view
@@ -85,6 +85,7 @@ import Options.Applicative import qualified Options.Applicative as OA import System.Environment+import System.Exit import System.FilePath import Test.Sandwich.ArgParsing import Test.Sandwich.Contexts@@ -118,7 +119,9 @@ -- | Run the spec with the given 'Options'. runSandwich :: Options -> CoreSpec -> IO ()-runSandwich options spec = void $ runSandwich' Nothing options spec+runSandwich options spec = do+ (_exitReason, failures) <- runSandwich' Nothing options spec+ when (0 < failures) $ exitFailure -- | Run the spec, configuring the options from the command line. runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()@@ -198,9 +201,11 @@ -- Wrap the spec in a finalizer for the test timer, when one is present let spec = case baseContextTestTimer baseContext of NullTestTimer -> spec'- _ -> after' (defaultNodeOptions { nodeOptionsRecordTime = False- , nodeOptionsVisibilityThreshold = systemVisibilityThreshold- , nodeOptionsCreateFolder = False }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec'+ _ -> after' (defaultNodeOptions {+ nodeOptionsRecordTime = False+ , nodeOptionsVisibilityThreshold = systemVisibilityThreshold+ , nodeOptionsCreateFolder = False+ }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec' rts <- startSandwichTree' baseContext options spec
src/Test/Sandwich/ArgParsing.hs view
@@ -129,6 +129,9 @@ commandLineWebdriverOptions :: (forall f a. Mod f a) -> Parser CommandLineWebdriverOptions commandLineWebdriverOptions maybeInternal = CommandLineWebdriverOptions <$> optional (browserToUse maybeInternal)++ <*> flag False True (long "chrome-no-sandbox" <> help "Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix)" <> maybeInternal)+ <*> optional (display maybeInternal) <*> flag False True (long "fluxbox" <> help "Launch fluxbox as window manager when using Xvfb" <> maybeInternal) <*> flag False True (long "individual-videos" <> help "Record individual videos of each test (requires ffmpeg and Xvfb)" <> maybeInternal)
src/Test/Sandwich/Internal/Running.hs view
@@ -161,7 +161,9 @@ where newShorthand = getShorthand taken x getShorthand :: [T.Text] -> NodeModuleInfo -> T.Text- getShorthand taken nmi = head $ filter (\x -> x `notElem` taken && x `notElem` takenMainOptions) $ getCandidates nmi+ getShorthand taken nmi = case filter (\x -> x `notElem` taken && x `notElem` takenMainOptions) $ getCandidates nmi of+ [] -> "unknown"+ (x:_) -> x getCandidates :: NodeModuleInfo -> [T.Text] getCandidates (NodeModuleInfo {nodeModuleInfoModuleName=modName}) = candidates
src/Test/Sandwich/Interpreters/StartTree.hs view
@@ -12,6 +12,7 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Trans.Reader import Data.IORef@@ -52,7 +53,7 @@ let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case+ (timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr) return (result, mkSetupTimingInfo setupFinishTime)@@ -74,7 +75,8 @@ result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx) (do- (ret, teardownStartTime, _teardownFinishTime) <- timed (runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]))+ (ret, teardownStartTime, _teardownFinishTime) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $+ runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) ) liftIO $ readIORef result@@ -86,13 +88,16 @@ bracket (do let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $- timed (runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])))+ timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $+ runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])+ ) (\(ret, setupStartTime, setupFinishTime) -> case ret of Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) Right intro -> do teardownStartTime <- getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime- ret' <- runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])+ (ret', _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $+ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) ) (\(ret, _setupStartTime, setupFinishTime) -> do@@ -125,24 +130,39 @@ _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do beginningCleanupVar <- liftIO $ newIORef Nothing++ -- Record a start event in the test timing, if configured+ -- TODO: how to do this? The speedscope viewer crashes if you don't properly nest events+ -- let tt = if runTreeRecordTime then getTestTimer (getBaseContext ctx) else NullTestTimer+ -- let setupLabel = runTreeLabel <> " (setup)"+ -- let teardownLabel = runTreeLabel <> " (teardown)"+ -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel)+ results <- runNodeIntroduceAction $ \intro -> do+ -- Record the end event in the test timing+ -- TODO: do we need to deal with exceptions here and in teardown? I think we we fail to emit the+ -- end event, the time profile won't be viewable.+ -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel) setupFinishTime <- liftIO getCurrentTime addSetupFinishTimeToStatus runTreeStatus setupFinishTime - results <- liftIO $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctx)+ (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $+ liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx) teardownStartTime <- liftIO getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime- liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime) + liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime)+ -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel) liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime) return results liftIO (readIORef beginningCleanupVar) >>= \case Nothing -> return ()- Just teardownStartTime ->- liftIO $ modifyIORef' didRunWrappedAction $- \(ret, timingInfo) -> (ret, timingInfo { teardownStartTime = Just teardownStartTime })+ Just teardownStartTime -> do+ -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel)+ liftIO $ modifyIORef' didRunWrappedAction $ \(ret, timingInfo) ->+ (ret, timingInfo { teardownStartTime = Just teardownStartTime }) return results @@ -184,7 +204,7 @@ startTree node@(RunNodeParallel {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeChildren ctx) >>= \case+ ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeCommon runNodeChildren ctx) >>= \case 0 -> return (Success, emptyExtraTimingInfo) n -> return (Failure (ChildrenFailed Nothing n), emptyExtraTimingInfo) startTree node@(RunNodeIt {..}) ctx' = do@@ -198,9 +218,7 @@ runInAsync node ctx action = do let RunNodeCommonWithStatus {..} = runNodeCommon node let bc@(BaseContext {..}) = getBaseContext ctx- let timerFn = case runTreeRecordTime of- True -> timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel)- _ -> id+ let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id startTime <- liftIO getCurrentTime mvar <- liftIO newEmptyMVar myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do@@ -266,20 +284,33 @@ liftIO $ putMVar mvar () return myAsync -- TODO: fix race condition with writing to runTreeStatus (here and above) --- | Run a list of children sequentially, cancelling everything on async exception TODO+-- | Run a list of children sequentially, cancelling everything on async exception runNodesSequentially :: HasBaseContext context => [RunNode context] -> context -> IO [Result] runNodesSequentially children ctx = flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ forM (L.filter (shouldRunChild ctx) children) $ \child -> startTree child ctx >>= wait --- | Run a list of children sequentially, cancelling everything on async exception TODO-runNodesConcurrently :: HasBaseContext context => [RunNode context] -> context -> IO [Result]-runNodesConcurrently children ctx =+-- | Run a list of children concurrently, cancelling everything on async exception+runNodesConcurrently :: forall context. HasBaseContext context => RunNodeCommon -> [RunNode context] -> context -> IO [Result]+runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) children ctx = flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $- mapM wait =<< sequence [startTree child ctx- | child <- L.filter (shouldRunChild ctx) children]+ mapM wait =<< sequence [startTree child (modifyTimingProfile ix ctx)+ | (child, ix) <- L.zip runnableChildren [0..]]+ where+ runnableChildren = L.filter (shouldRunChild ctx) children + leftPadWithZeros :: Int -> String+ leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num++ modifyTimingProfile :: Int -> context -> context+ modifyTimingProfile n = flip modifyBaseContext (modifyTimingProfile' n)++ modifyTimingProfile' :: Int -> BaseContext -> BaseContext+ modifyTimingProfile' n bc@(BaseContext {..}) = bc {+ baseContextTestTimerProfile = baseContextTestTimerProfile <> [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|]+ }+ markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () markAllChildrenWithResult children baseContext status = do now <- liftIO getCurrentTime@@ -372,9 +403,11 @@ Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret _ -> Done endTime Nothing Nothing endTime ret -timed :: (MonadIO m) => m a -> m (a, UTCTime, UTCTime)-timed action = do+timed :: (MonadUnliftIO m) => Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime)+timed recordTime bc@(BaseContext {..}) label action = do+ let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id+ startTime <- liftIO getCurrentTime- ret <- action+ ret <- timerFn action endTime <- liftIO getCurrentTime pure (ret, startTime, endTime)
src/Test/Sandwich/ParallelN.hs view
@@ -31,7 +31,18 @@ import UnliftIO.Exception +-- * Types +parallelSemaphore :: Label "parallelSemaphore" QSem+parallelSemaphore = Label++type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem++defaultParallelNodeOptions :: NodeOptions+defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 }++-- * Functions+ -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. parallelN :: ( MonadUnliftIO m@@ -47,11 +58,7 @@ -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()-parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $- parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children- where claimRunSlot f = do- s <- getContext parallelSemaphore- bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f)+parallelN' nodeOptions n = parallelN'' nodeOptions (liftIO $ newQSem n) -- | Same as 'parallelN', but extracts the semaphore size from the command line options. parallelNFromArgs :: forall context a m. (@@ -72,21 +79,20 @@ -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()-parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $- parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children+parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f where- getQSem = do- n <- getParallelism <$> getContext commandLineOptions- liftIO $ newQSem n+ f = (getParallelism <$> getContext commandLineOptions) >>= liftIO . newQSem +parallelN'' :: (+ MonadUnliftIO m+ )+ => NodeOptions+ -> ExampleT context m QSem+ -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m ()+ -> SpecFree context m ()+parallelN'' nodeOptions makeQSem children = introduce "Introduce parallel semaphore" parallelSemaphore makeQSem (const $ return ()) $+ parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children+ where claimRunSlot f = do s <- getContext parallelSemaphore bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f)--parallelSemaphore :: Label "parallelSemaphore" QSem-parallelSemaphore = Label--type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem--defaultParallelNodeOptions :: NodeOptions-defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 }
src/Test/Sandwich/TH.hs view
@@ -27,7 +27,6 @@ import Safe import System.Directory import System.FilePath as F-import Test.Sandwich.TH.HasMainFunction import Test.Sandwich.TH.ModuleMap import Test.Sandwich.Types.Spec hiding (location) @@ -41,6 +40,8 @@ , getSpecWarnOnParseError :: ShouldWarnOnParseError } +{-# DEPRECATED getSpecWarnOnParseError "Not used anymore." #-}+ defaultGetSpecFromFolderOptions :: GetSpecFromFolderOptions defaultGetSpecFromFolderOptions = GetSpecFromFolderOptions { getSpecCombiner = 'describe@@ -48,6 +49,10 @@ , getSpecWarnOnParseError = WarnOnParseError } +{-# DEPRECATED ShouldWarnOnParseError "Not used anymore." #-}+data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError+ deriving (Eq)+ getSpecFromFolder :: GetSpecFromFolderOptions -> Q Exp getSpecFromFolder getSpecFromFolderOptions = do dir <- runIO getCurrentDirectory@@ -86,10 +91,7 @@ reportError [i|Couldn't find module #{fullyQualifiedModule} in #{reverseModuleMap}|] return Nothing Just importedName -> do- maybeMainFunction <- fileHasMainFunction (folder </> item) getSpecWarnOnParseError >>= \case- True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]- False -> [e|Nothing|]-+ maybeMainFunction <- getMaybeMainFunction importedName alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) fullyQualifiedModule $(return maybeMainFunction)) })|] Just <$> [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)@@ -103,14 +105,22 @@ & T.unpack maybeMainFunction <- case M.lookup currentModule reverseModuleMap of Nothing -> [e|Nothing|]- Just importedName -> fileHasMainFunction (folder <> ".hs") getSpecWarnOnParseError >>= \case- True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]- False -> [e|Nothing|]+ Just importedName -> getMaybeMainFunction importedName alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) currentModule $(return maybeMainFunction)) })|] [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn) $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl (>>) (pure ()) $(listE $ fmap return specs))|] -- * Util++-- | Detect if a main function is present in the given module by trying to reify it,+-- using 'recover' to handle exceptions.+-- We could also look at the actual reified value to see if it looks like a function,+-- but that's probably overkill.+getMaybeMainFunction :: String -> Q Exp+getMaybeMainFunction importedName = do+ let mainName = mkName (importedName <> ".main")+ recover [e|Nothing|]+ (reify mainName >> [e|Just $(varE mainName)|]) mangleFolderName :: String -> String mangleFolderName = T.unpack . wordify . T.pack . takeBaseName
− src/Test/Sandwich/TH/HasMainFunction.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TemplateHaskell #-}--module Test.Sandwich.TH.HasMainFunction (- fileHasMainFunction- , ShouldWarnOnParseError(..)- ) where--import Control.Monad-import Data.String.Interpolate-import Language.Haskell.Exts hiding (name)-import Language.Haskell.TH (Q, runIO, reportWarning)---- import Debug.Trace---data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError- deriving (Eq)---- | Use haskell-src-exts to determine if a give Haskell file has an exported main function--- Parse with all extensions enabled, which will hopefully parse anything-fileHasMainFunction :: FilePath -> ShouldWarnOnParseError -> Q Bool-fileHasMainFunction path shouldWarnOnParseError = runIO (parseFileWithExts [x | x@(EnableExtension _) <- knownExtensions] path) >>= \case- x@(ParseFailed {}) -> do- when (shouldWarnOnParseError == WarnOnParseError) $- reportWarning [i|Failed to parse #{path}: #{x}|]- return False- ParseOk (Module _ (Just moduleHead) _ _ decls) -> do- -- traceM [i|Sucessfully parsed #{path}: #{moduleHead}|]- case moduleHead of- ModuleHead _ _ _ (Just (ExportSpecList _ (any isMainFunction -> True))) -> do- -- traceM [i|FOUND MAIN FUNCTION FOR #{path}|]- return True- ModuleHead _ _ _ Nothing -> do- -- traceM [i|LOOKING FOR DECLS: #{decls}|]- return $ any isMainDecl decls- _ -> return False- ParseOk _ -> do- reportWarning [i|Successfully parsed #{path} but no module head found|]- return False--isMainFunction :: ExportSpec l -> Bool-isMainFunction (EVar _ name) = isMainFunctionQName name-isMainFunction _ = False--isMainFunctionQName :: QName l -> Bool-isMainFunctionQName (Qual _ _ name) = isMainFunctionName name-isMainFunctionQName (UnQual _ name) = isMainFunctionName name-isMainFunctionQName _ = False--isMainFunctionName :: Name l -> Bool-isMainFunctionName (Ident _ "main") = True-isMainFunctionName (Symbol _ "main") = True-isMainFunctionName _ = False--isMainDecl :: Decl l -> Bool-isMainDecl (PatBind _ (PVar _ (Ident _ "main")) _ _) = True--- isMainDecl decl = trace [i|Looking at decl: #{decl}|] False-isMainDecl _ = False
src/Test/Sandwich/TestTimer.hs view
@@ -3,9 +3,21 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} -module Test.Sandwich.TestTimer where+module Test.Sandwich.TestTimer (+ timeAction+ , timeAction'+ , timeActionByProfile -import Control.Concurrent+ , handleStartEvent+ , handleEndEvent++ , withTimingProfile+ , withTimingProfile'++ , newSpeedScopeTestTimer+ , finalizeSpeedScopeTestTimer+ ) where+ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader@@ -17,6 +29,7 @@ import Data.String.Interpolate import qualified Data.Text as T import qualified Data.Text.IO as T+import Data.Time import Data.Time.Clock.POSIX import Lens.Micro import System.Directory@@ -26,6 +39,7 @@ import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util (whenJust)+import UnliftIO.Concurrent import UnliftIO.Exception @@ -76,9 +90,11 @@ -- * Core timingNodeOptions :: NodeOptions-timingNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False- , nodeOptionsCreateFolder = False- , nodeOptionsVisibilityThreshold = systemVisibilityThreshold }+timingNodeOptions = defaultNodeOptions {+ nodeOptionsRecordTime = False+ , nodeOptionsCreateFolder = False+ , nodeOptionsVisibilityThreshold = systemVisibilityThreshold+ } newSpeedScopeTestTimer :: FilePath -> Bool -> IO TestTimer newSpeedScopeTestTimer path writeRawTimings = do@@ -103,38 +119,59 @@ timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a timeAction' NullTestTimer _ _ = id timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_- (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do- now <- getPOSIXTime- handleStartEvent file now- )- (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do- now <- getPOSIXTime- handleEndEvent file now- )- where- handleStartEvent file time = do- whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|]- return $ handleSpeedScopeEvent file time SpeedScopeEventTypeOpen+ (modifyMVar_ testTimerSpeedScopeFile $ \file -> liftIO getPOSIXTime >>= handleStartEvent' testTimerHandle profileName eventName file)+ (modifyMVar_ testTimerSpeedScopeFile $ \file -> liftIO getPOSIXTime >>= handleEndEvent' testTimerHandle profileName eventName file) - handleEndEvent file time = do- whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|]- return $ handleSpeedScopeEvent file time SpeedScopeEventTypeClose+handleStartEvent :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m ()+handleStartEvent NullTestTimer _profileName _eventName = return ()+handleStartEvent (SpeedScopeTestTimer {..}) profileName eventName =+ modifyMVar_ testTimerSpeedScopeFile $ \file ->+ liftIO getPOSIXTime >>= handleStartEvent' testTimerHandle profileName eventName file - -- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists,- -- so we don't have to do O(N) L.length and S.findIndexL- handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> SpeedScopeEventType -> SpeedScopeFile- handleSpeedScopeEvent initialFile time eventType = flip execState initialFile $ do- frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of- Just j -> return j- Nothing -> do- modify' $ over (shared . frames) (S.|> (SpeedScopeFrame eventName))- return $ S.length $ f ^. shared . frames+handleStartEvent' :: (MonadIO m)+ => Maybe Handle+ -> T.Text+ -> T.Text+ -> SpeedScopeFile+ -> NominalDiffTime+ -> m SpeedScopeFile+handleStartEvent' maybeHandle profileName eventName file time = do+ whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|]+ return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeOpen - profileIndex <- get >>= \f -> case L.findIndex ((== profileName) . (^. name)) (f ^. profiles) of- Just j -> return j- Nothing -> do- modify' $ over profiles (\x -> x <> [newProfile profileName time])- return $ L.length (f ^. profiles)+handleEndEvent :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m ()+handleEndEvent NullTestTimer _profileName _eventName = return ()+handleEndEvent (SpeedScopeTestTimer {..}) profileName eventName =+ modifyMVar_ testTimerSpeedScopeFile $ \file ->+ liftIO getPOSIXTime >>= handleEndEvent' testTimerHandle profileName eventName file - modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time))- . over (profiles . ix profileIndex . endValue) (max time)+handleEndEvent' :: (MonadIO m)+ => Maybe Handle+ -> T.Text+ -> T.Text+ -> SpeedScopeFile+ -> NominalDiffTime+ -> m SpeedScopeFile+handleEndEvent' maybeHandle profileName eventName file time = do+ whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|]+ return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeClose+++-- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists,+-- so we don't have to do O(N) L.length and S.findIndexL+handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> T.Text -> T.Text -> SpeedScopeEventType -> SpeedScopeFile+handleSpeedScopeEvent initialFile time profileName eventName eventType = flip execState initialFile $ do+ frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of+ Just j -> return j+ Nothing -> do+ modify' $ over (shared . frames) (S.|> (SpeedScopeFrame eventName))+ return $ S.length $ f ^. shared . frames++ profileIndex <- get >>= \f -> case L.findIndex ((== profileName) . (^. name)) (f ^. profiles) of+ Just j -> return j+ Nothing -> do+ modify' $ over profiles (\x -> x <> [newProfile profileName time])+ return $ L.length (f ^. profiles)++ modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time))+ . over (profiles . ix profileIndex . endValue) (max time)
src/Test/Sandwich/Types/ArgParsing.hs view
@@ -133,7 +133,10 @@ deriving Show data CommandLineWebdriverOptions = CommandLineWebdriverOptions {- optFirefox :: Maybe BrowserToUse+ optBrowserToUse :: Maybe BrowserToUse++ , optChromeNoSandbox :: Bool+ , optDisplay :: Maybe DisplayType , optFluxbox :: Bool , optIndividualVideos :: Bool
src/Test/Sandwich/Util/Process.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE CPP #-} module Test.Sandwich.Util.Process ( gracefullyStopProcess , gracefullyWaitForProcess++ , gracefullyStopProcess'+ , gracefullyWaitForProcess'++ , StopProcessResult(..) ) where import Control.Monad@@ -13,33 +19,71 @@ import System.Process import Test.Sandwich.Logging +#ifndef mingw32_HOST_OS+import System.Posix.Signals (signalProcess, sigKILL)+#endif --- | Interrupt a process and wait for it to terminate.++data StopProcessResult =+ StoppedByItself+ | StoppedAfterInterrupt+ | StoppedAfterTerminate+ | StoppedAfterKill+ | FailedToStop+ deriving (Show, Eq, Ord, Enum)++-- | Interrupt a process and wait for it to terminate, returning a 'StopProcessResult'. gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()-gracefullyStopProcess p gracePeriodUs = do+gracefullyStopProcess p gracePeriodUs = void $ gracefullyStopProcess' p gracePeriodUs++-- | Interrupt a process and wait for it to terminate.+gracefullyStopProcess' :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m StopProcessResult+gracefullyStopProcess' p gracePeriodUs = do liftIO $ interruptProcessGroupOf p- gracefullyWaitForProcess p gracePeriodUs+ gracefullyWaitForProcess' p gracePeriodUs -- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds, -- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds. -- After this time elapses send a terminate signal and wait for the process to die. gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()-gracefullyWaitForProcess p gracePeriodUs = do+gracefullyWaitForProcess p gracePeriodUs = void $ gracefullyWaitForProcess' p gracePeriodUs++-- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds,+-- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds.+-- After this time elapses send a terminate signal and wait for the process to die.+gracefullyWaitForProcess' :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m StopProcessResult+gracefullyWaitForProcess' p gracePeriodUs = do let waitForExit = do let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000 retrying policy (\_ x -> return $ isNothing x) $ \_ -> do liftIO $ getProcessExitCode p waitForExit >>= \case- Just _ -> return ()+ Just _ -> return StoppedByItself Nothing -> do- pid <- liftIO $ getPid p- warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]+ liftIO (getPid p) >>= \case+ Nothing -> return StoppedByItself+ Just pid -> do+ warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|] - liftIO $ interruptProcessGroupOf p- waitForExit >>= \case- Just _ -> return ()- Nothing -> void $ do- warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]- liftIO $ terminateProcess p- liftIO $ waitForProcess p+ liftIO $ interruptProcessGroupOf p+ waitForExit >>= \case+ Just _ -> return StoppedAfterInterrupt+ Nothing -> do+ warn [i|(#{pid}) Process didn't stop after another sigINT and a further #{gracePeriodUs}us; going to terminate|]+ liftIO $ terminateProcess p++#ifdef mingw32_HOST_OS+ waitForExit >>= \case+ Just _ -> return StoppedAfterKill+ Nothing -> return FailedToStop+#else+ waitForExit >>= \case+ Just _ -> return StoppedAfterTerminate+ Nothing -> do+ warn [i|(#{pid}) Process didn't stop after sigTERM and a further #{gracePeriodUs}us; going to kill|]+ liftIO $ signalProcess sigKILL pid+ waitForExit >>= \case+ Just _ -> return StoppedAfterKill+ Nothing -> return FailedToStop+#endif