From 4c43810a1202a0321871497bea17903a6214fa79 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 14 Sep 2024 21:17:23 +0000 Subject: [PATCH 01/43] WIP --- examples/DocumenterDemo.hs | 178 ++++++++++++++++++++++++------------- src/Check.hs | 2 + 2 files changed, 119 insertions(+), 61 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 7e1e790e..799327d9 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -1,54 +1,33 @@ +{-# LANGUAGE NoStrictData #-} + module DocumenterDemo where -import DSL.Internal.NodeEvent (NodeEvent (User), UserLog (Log)) +import Check +import Core (ParseException) +import DSL.FileSystemDocInterpreter qualified as FDoc +import DSL.FileSystemEffect +import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) import DSL.Out (Out, out) +import Data.Text (isInfixOf) import Effectful as EF ( Eff, IOE, runEff, type (:>), ) -import PyrethrumBase -import PyrethrumExtras (txt, Abs, File, relfile, (?), toS) -import WebDriverSpec (Selector (CSS)) -import Filter (Filters(..)) -import Internal.SuiteRuntime (ThreadCount(..)) +import Filter (Filters (..)) import Internal.Logging qualified as L -import DSL.FileSystemEffect -import Path as P (Path, reldir, toFilePath) -import Data.Text (isInfixOf) -import FileSystemDocDemo (FSOut) -import qualified DSL.FileSystemDocInterpreter as FDoc - -{- -demo the following: - - single test suite with minimal selenium interpreter - - read a value from "the internet" - - navigate between pages - - read a second value - - validator on value - - expect issue with laziness (if not why not) - - solve - - user steps - - run with documenter - - introduce action that uses value read from the internet - - should blow up documenter - - fix with doc* functions - - TODO: Haddock docs for steps - - effectful supports generating template haskell without type signature - - manually add type signature and haddock --} - --- ################### Effectful Demo ################## - -_theInternet :: Text -_theInternet = "https://the-internet.herokuapp.com/" +import Internal.SuiteRuntime (ThreadCount (..)) +import Path as P (Path, reldir, toFilePath) +import PyrethrumBase +import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) +import WebDriverEffect +import WebDriverPure (seconds) +import WebDriverSpec (DriverStatus (..), Selector (CSS)) -_checkBoxesLinkCss :: Selector -_checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" runDemo :: SuiteRunner -> Suite -> IO () -runDemo runner suite = do +runDemo runner suite = do (logControls, _logQ) <- L.testLogControls True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls @@ -61,7 +40,6 @@ logShow = out . User . Log . txt log :: (HasLog es) => Text -> Eff es () log = out . User . Log - -- copied from FileSystemDocDemo.hs getPaths :: (Out NodeEvent :> es, FileSystem :> es) => Eff es [P.Path Abs File] @@ -78,37 +56,116 @@ getPaths = isDeleteMe :: P.Path Abs File -> Eff es Bool isDeleteMe = pure . isInfixOf "deleteMe" . toS . P.toFilePath --- #### 1. This has the behaviour we are after with a simple local interpreter +-- ######## 1. This has the behaviour we are after with a simple local interpreter ######## + +chkPathsThatDoesNothing :: [P.Path Abs File] -> Eff es () +chkPathsThatDoesNothing _ = pure () + -fsDemoAp :: forall es. (FSOut es) => Eff es () +fsDemoAp :: forall es. (Out NodeEvent :> es, FileSystem :> es) => Eff es () fsDemoAp = do paths <- getPaths - log . txt $ length paths - chk paths - where - chk :: [P.Path Abs File] -> Eff es () - chk _ = log "This is a check" + chkPathsThatDoesNothing paths fsDocDemoSimple :: IO () -fsDocDemoSimple = +fsDocDemoSimple = -- docInterpreter fsDemoAp docRun fsDemoAp - where + where docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a docRun = runEff . runDocOut . FDoc.runFileSystem + -- >>> fsDocDemoSimple -{- TODO: make documenter work with this (copy of Webdriver demo) +-- ################### 2. FS App with full runtime ################## + +fsSuiteDemo :: IO () +fsSuiteDemo = runDemo docRunner fsSuite + +-- 1. log scrambling +-- 2. exception not handled +-- 3. laziness not working + +-- TODO: EXception not handled !!!!!!! +-- >>> fsSuiteDemo +-- *** Exception: +-- Exception thrown in step documentation. +-- Value forced from function: 'findFilesWith' in documentation mode. +-- Use docVal, docHush, docVoid, docVal' to replace or silence this value from where the step is called: 'findFilesWith' + +-- TODO: fix filter log +fsSuite :: Suite +fsSuite = + [Fixture (NodePath "FS Demo Test" "test") fstest] + +fstest :: Fixture () +fstest = Full config fsAction parsefs fsItems + +getFail :: Eff es FSAS +getFail = pure $ error "This is an error !!! " + +fsAction :: (FileSystem :> es, Out NodeEvent :> es) => RunConfig -> FSData -> Eff es FSAS +fsAction _rc i = do + getFail + paths <- getPaths + log i.title + chkPathsThatDoesNothing paths + pure $ FSAS {paths} + +data FSData = FSItem + { id :: Int, + title :: Text, + checks :: Checks FSDS + } + deriving (Show, Read) + +{- +TODO: compile error example +data FSData = FSItem + { id :: Int, + title :: Text, + checks :: Checks DS + } + deriving (Show, Read) +-} + + +newtype FSAS = FSAS + { paths :: [P.Path Abs File] + } + deriving (Show) + +newtype FSDS = FSDS + { paths :: [P.Path Abs File] + } + deriving (Show) + +parsefs :: FSAS -> Either ParseException FSDS +parsefs FSAS {..} = pure $ FSDS {..} + +fsItems :: RunConfig -> DataSource FSData +fsItems _rc = + ItemList + [ FSItem + { id = 1, + title = "test the file system", + checks = + chk "Paths exist" (not . null . (.paths)) + } + ] + + +-- ################### WebDriver Test ################## + +docWebDriverDemo :: IO () +docWebDriverDemo = runDemo docRunner webDriverSuite + +-- >>> docWebDriverDemo webDriverSuite :: Suite webDriverSuite = [Fixture (NodePath "WebDriverDemo" "test") test] -runWebDriverDemo :: SuiteRunner -> IO () -runWebDriverDemo runner = do - (logControls, _logQ) <- L.testLogControls True - runner webDriverSuite Unfiltered defaultRunConfig (ThreadCount 1) logControls - test :: Fixture () test = Full config action parse items @@ -116,17 +173,18 @@ config :: FixtureConfig config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus -driver_status = do +driver_status = do status <- driverStatus "NA" log $ "the driver status is: " <> txt status pure status -runIODemo :: IO () -runIODemo = runDemo ioRunner --- >>> runIODemo +_theInternet :: Text +_theInternet = "https://the-internet.herokuapp.com/" +_checkBoxesLinkCss :: Selector +_checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" -action :: (WebUI :> es, Out NodeEvent :> es, FileSystem :> es) => RunConfig -> Data -> Eff es AS +action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS action _rc i = do log i.title status <- driver_status @@ -175,5 +233,3 @@ items _rc = <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) } ] - --} diff --git a/src/Check.hs b/src/Check.hs index dd53c464..b012440c 100644 --- a/src/Check.hs +++ b/src/Check.hs @@ -15,6 +15,8 @@ module Check ( skipCheck, mapRules, filterRules, + -- TODO - more checks chkFalse', ChkEmpty, chkNotEmpty, chkEqual, chkNotEqual, chkContains, + -- chkNotContains, chkMatches, chkNotMatches, chkLessThan, chkLessThanOrEqual, chkGreaterThan, chkGreaterThanOrEqual ) where From 1e111fc1b57e1d7591b4f37f22531dd7c2837ec8 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 17 Sep 2024 20:13:19 +0000 Subject: [PATCH 02/43] prepare to create proper Out interpreters --- examples/DocumenterDemo.hs | 50 +++++++++++++++++------ examples/PyrethrumBase.hs | 38 +++++++++++------- examples/WebDriverDemo.hs | 2 +- pyrethrum.cabal | 4 +- src/DSL/DocInterpreterUtils.hs | 14 ++++++- src/DSL/FileSystemDocInterpreter.hs | 16 +++++--- src/Internal/Logging.hs | 17 ++++---- src/Internal/LoggingCore.hs | 15 +++++-- src/Internal/OutDocInterpreter.hs | 20 ++++++++++ src/Internal/OutIOInterpreter.hs | 21 ++++++++++ src/Internal/SuiteRuntime.hs | 7 ++-- src/Prepare.hs | 62 ++++++++++++++--------------- test/SuiteRuntimeTest.hs | 2 +- test/SuiteRuntimeTestBase.hs | 14 ++----- 14 files changed, 188 insertions(+), 94 deletions(-) create mode 100644 src/Internal/OutDocInterpreter.hs create mode 100644 src/Internal/OutIOInterpreter.hs diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 799327d9..d3277604 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -18,18 +18,43 @@ import Effectful as EF import Filter (Filters (..)) import Internal.Logging qualified as L import Internal.SuiteRuntime (ThreadCount (..)) +import Text.Show.Pretty (pPrint) import Path as P (Path, reldir, toFilePath) import PyrethrumBase + ( SuiteRunner, + Suite, + RunConfig, + FixtureConfig(FxCfg), + HasLog, + Fixture(Full), + Node(Fixture), + DataSource(ItemList), + Depth(DeepRegression), + defaultRunConfig, + runDocOut, + docRunner ) import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) import WebDriverEffect + ( WebUI, + driverStatus, + newSession, + maximiseWindow, + go, + findElem, + readElem, + clickElem, + sleep, + killSession ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) runDemo :: SuiteRunner -> Suite -> IO () runDemo runner suite = do - (logControls, _logQ) <- L.testLogControls True + (logControls, logList) <- L.testLogControls True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls + putStrLn "########## Log ##########" + atomically logList >>= mapM_ pPrint -- ############### Test Case ################### @@ -79,19 +104,20 @@ fsDocDemoSimple = -- ################### 2. FS App with full runtime ################## +{- +OH THE HUMANITY !!! +1. log scrambling + 1.1 - take unhandled excption out of the picture in demo - FAILED STILL SCRABLED + 1.2 - switch off filter log (execute -> executeWithoutValidation) - FAILED STILL SCRABLED + 1.3 - log outfull channel +2. exception not handled +3. laziness not working +-} + fsSuiteDemo :: IO () fsSuiteDemo = runDemo docRunner fsSuite --- 1. log scrambling --- 2. exception not handled --- 3. laziness not working - --- TODO: EXception not handled !!!!!!! -- >>> fsSuiteDemo --- *** Exception: --- Exception thrown in step documentation. --- Value forced from function: 'findFilesWith' in documentation mode. --- Use docVal, docHush, docVoid, docVal' to replace or silence this value from where the step is called: 'findFilesWith' -- TODO: fix filter log fsSuite :: Suite @@ -106,7 +132,7 @@ getFail = pure $ error "This is an error !!! " fsAction :: (FileSystem :> es, Out NodeEvent :> es) => RunConfig -> FSData -> Eff es FSAS fsAction _rc i = do - getFail + -- getFail paths <- getPaths log i.title chkPathsThatDoesNothing paths @@ -120,7 +146,7 @@ data FSData = FSItem deriving (Show, Read) {- -TODO: compile error example +TODO: make better compile error example data FSData = FSItem { id :: Int, title :: Text, diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 6a95f0f8..fe5b5b9f 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -34,7 +34,7 @@ import Effectful (Eff, IOE, runEff, type (:>)) import Filter (Filters) import Internal.Logging qualified as L import Internal.LoggingCore qualified as L -import Internal.SuiteRuntime (ThreadCount, execute) +import Internal.SuiteRuntime (ThreadCount, execute, executeWithoutValidation) import PyrethrumConfigTypes as CG ( Country (..), Depth (..), @@ -47,6 +47,10 @@ import PyrethrumConfigTypes as CG import WebDriverDocInterpreter qualified as WDDoc (runWebDriver) import WebDriverEffect (WebUI (..)) import WebDriverIOInterpreter qualified as WDIO (runWebDriver) +import Prepare (prepare, PreNode) +import PyrethrumExtras (txt) +import Internal.SuiteValidation (SuiteValidationError) +import Internal.SuiteFiltering (FilteredSuite(..)) -- these will probably be split off and go into core or another library -- module later @@ -72,15 +76,31 @@ ioInterpreter ap = & runEff +-- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +-- docRunner suite filters runConfig threadCount logControls = +-- execute threadCount logControls $ +-- C.MkSuiteExeParams +-- { interpreter = docInterpreter, +-- suite = mkCoreSuite suite, +-- filters, +-- runConfig +-- } + docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () docRunner suite filters runConfig threadCount logControls = - execute threadCount logControls $ - C.MkSuiteExeParams + prepared & either + print + (\s -> executeWithoutValidation threadCount logControls s.suite) + where + prepared :: Either SuiteValidationError (FilteredSuite (PreNode IO ())) + prepared = prepare $ C.MkSuiteExeParams { interpreter = docInterpreter, suite = mkCoreSuite suite, filters, runConfig } + + ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () ioRunner suite filters runConfig threadCount logControls = @@ -102,18 +122,6 @@ docInterpreter ap = --- TODO - interpreters into own module --- Need to fix up to work in with logcontrols --- there are currently 2 paths to STD out I think ?? -runIOOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a -runIOOut = runOut print - --- in doc mode we supress log -runDocOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a -runDocOut = - runOut $ \case - AE.Framework l -> print l - AE.User _l -> pure () {- runErrorIO :: forall a e es. Exception e => Eff (Error e : es) a -> Eff es (Either (CallStack, SomeException) a) diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index bbfea625..d28a3d30 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -32,7 +32,7 @@ suite = runDemo :: SuiteRunner -> IO () runDemo runner = do - (logControls, _logQ) <- L.testLogControls True + (logControls, _logLst) <- L.testLogControls True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls -- start geckodriver first: geckodriver & diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 405fffe8..453e49ce 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: 16468d979d1b36dd622ebb58bab1be3020b60592a9169ee95ebc50de02547cc5 +-- hash: 51fa65cc469499e2950ccd8a46ec67a71dc18e4925baf5eee83cfaf49f730427 name: pyrethrum version: 0.1.0.0 @@ -94,6 +94,8 @@ library Internal.Logging Internal.LoggingCore Internal.LogQueries + Internal.OutDocInterpreter + Internal.OutIOInterpreter Internal.SuiteFiltering Internal.SuiteRuntime Internal.SuiteValidation diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index cdd22409..4356728c 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -5,7 +5,8 @@ module DSL.DocInterpreterUtils ( docErr2, docErr3, docErr4, - docErrn + docErrn, + docErrn' ) where import DSL.Out ( out, Out ) @@ -53,6 +54,8 @@ docErrn funcName dscFrags = -- TODO :: replace this later when have code to process call -- stack right now out of the box call handling looks better -- E.throwError . DocException $ + pure $ error "" + {- pure . error $ "\nException thrown in step documentation." <> "\n Value forced from function: '" @@ -62,6 +65,15 @@ docErrn funcName dscFrags = <> " to replace or silence this value from where the step is called: '" <> funcName <> "'" + -} + +docErrn' :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> [Text] -> a -> Eff es a +docErrn' funcName dscFrags mockValue = + do + let funcDesc = T.intercalate " " dscFrags + logStep funcDesc + pure mockValue + docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> Text -> Eff es a docErr funcName funcDesc = docErrn funcName [funcDesc] diff --git a/src/DSL/FileSystemDocInterpreter.hs b/src/DSL/FileSystemDocInterpreter.hs index 4ade0074..e29d5234 100644 --- a/src/DSL/FileSystemDocInterpreter.hs +++ b/src/DSL/FileSystemDocInterpreter.hs @@ -15,7 +15,7 @@ import DSL.FileSystemEffect (FileSystem (..)) import Path.Extended (Path, toFilePath) import PyrethrumExtras (toS, txt, (?)) import Effectful.Dispatch.Dynamic (LocalEnv, interpret) -import DSL.DocInterpreterUtils (docErr, docErr2, docErr3, docErr4) +import DSL.DocInterpreterUtils (docErr, docErr2, docErr3, docErr4, docErrn') import DSL.Internal.NodeEvent (NodeEvent) -- TODO: implement docVal, docHush, docVoid, docVal', or docVoid' @@ -36,12 +36,16 @@ runFileSystem = -- todo: rename all variables / separate type signatures by using the other templateHaskell method WithCurrentDir _path _action -> docErr "withCurrentDir" "run action in current working directory" FindFilesWith _predicate searchDirs targetFileName -> - docErr4 + -- docErr4 + -- "findFilesWith" + -- "find all files that match the file name:" + -- (showPath targetFileName) + -- "and satisfy the given predicate in directories:" + -- (showPaths searchDirs) + docErrn' "findFilesWith" - "find all files that match the file name:" - (showPath targetFileName) - "and satisfy the given predicate in directories:" - (showPaths searchDirs) + ["find all files that match the file name:", showPath targetFileName, "and satisfy the given predicate in directories:", showPaths searchDirs] + [] FindFileWith _predicate searchDirs targetFileName -> docErr4 "findFileWith" diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 70d3a029..cb2f192a 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -14,6 +14,7 @@ import Filter (FilterResult) import Internal.LoggingCore import PyrethrumExtras as PE (head, tail, (?)) import Prelude hiding (atomically, lines) +import UnliftIO (tryReadTQueue) type Log l a = BaseLog LogContext (Event l a) @@ -89,7 +90,7 @@ data FailPoint = FailPoint mkFailure :: l -> NodeType -> SomeException -> Event l a mkFailure loc nodeType exception = Failure {exception = C.exceptionTxt exception, ..} -data Event l a +data Event loc evnt = FilterLog { filterResuts :: [FilterResult Text] } @@ -100,30 +101,30 @@ data Event l a | StartExecution | Start { nodeType :: NodeType, - loc :: l + loc :: loc } | End { nodeType :: NodeType, - loc :: l + loc :: loc } | Failure { nodeType :: NodeType, - loc :: l, + loc :: loc, exception :: C.PException } | ParentFailure - { loc :: l, + { loc :: loc, nodeType :: NodeType, - failLoc :: l, + failLoc :: loc, failSuiteEvent :: NodeType } | NodeEvent - { event :: a + { event :: evnt } | EndExecution deriving (Show) -testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), TQueue (Log l a)) +testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) testLogControls = testLogControls' expandEvent -- -- NodeEvent (a) a loggable event generated from within a node diff --git a/src/Internal/LoggingCore.hs b/src/Internal/LoggingCore.hs index c6a81fda..9026fe61 100644 --- a/src/Internal/LoggingCore.hs +++ b/src/Internal/LoggingCore.hs @@ -5,7 +5,7 @@ import BasePrelude qualified as P import CoreUtils qualified as C import Effectful.Concurrent.STM (TQueue) import Text.Show.Pretty (pPrint) -import UnliftIO (concurrently_, finally, newIORef) +import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue ) import UnliftIO.Concurrent (ThreadId) import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) import Prelude hiding (atomically, lines) @@ -62,7 +62,16 @@ data LogControls l lx = LogControls stopWorker :: IO () } -testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, TQueue lx) + +q2List :: TQueue a -> STM [a] +q2List qu = reverse <$> recurse [] qu + where + recurse :: [a] -> TQueue a -> STM [a] + recurse l q = + tryReadTQueue q + >>= maybe (pure l) (\e -> recurse (e : l) q) + +testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) testLogControls' aggregator wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -84,4 +93,4 @@ testLogControls' aggregator wantConsole = do writeTChan chn $ Just eventLog writeTQueue log eventLog - pure (LogControls {..}, log) + pure (LogControls {..}, q2List log) diff --git a/src/Internal/OutDocInterpreter.hs b/src/Internal/OutDocInterpreter.hs new file mode 100644 index 00000000..a6b2c806 --- /dev/null +++ b/src/Internal/OutDocInterpreter.hs @@ -0,0 +1,20 @@ +module Internal.OutDocInterpreter where + +-- Import necessary modules +import Data.Text (Text) +import Effectful as EF + ( Eff, + IOE, + runEff, + type (:>), + ) +import DSL.Internal.NodeEvent as AE +import DSL.Out + +-- !!!! This is wrong +-- in doc mode we supress log +runDocOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a +runDocOut = + runOut $ \case + AE.Framework l -> print l + AE.User _l -> pure () diff --git a/src/Internal/OutIOInterpreter.hs b/src/Internal/OutIOInterpreter.hs new file mode 100644 index 00000000..024f14eb --- /dev/null +++ b/src/Internal/OutIOInterpreter.hs @@ -0,0 +1,21 @@ +module Internal.OutIOInterpreter where + +-- Import necessary modules +import Data.Text (Text) +import Effectful as EF + ( Eff, + IOE, + runEff, + type (:>), + ) +import DSL.Internal.NodeEvent as AE +import DSL.Out + +-- Define your functions and types here + +-- TODO - interpreters into own module +-- Need to fix up to work in with logcontrols +-- there are currently 2 paths to STD out I think ?? +-- this is wrong +runIOOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a +runIOOut = runOut print diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 3bfdb333..b49c809a 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -46,15 +46,14 @@ execute tc lc prms = L.runWithLogger lc execute' where execute' :: L.LoggerSource (L.Event L.ExePath AE.NodeEvent) -> IO () - execute' l = + execute' l@L.MkLoggerSource{rootLogger} = do - let log = l.rootLogger P.prepare prms & either - (\Failure {failure, notes} -> log $ L.SuiteInitFailure failure notes) + (\Failure {failure, notes} -> rootLogger $ L.SuiteInitFailure failure notes) ( \validated -> do - log $ L.FilterLog validated.filterResults + rootLogger $ L.FilterLog validated.filterResults executeNodeList tc l validated.suite ) diff --git a/src/Prepare.hs b/src/Prepare.hs index 89bb3750..d36feb15 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -41,13 +41,12 @@ prepare C.MkSuiteExeParams {suite, filters, interpreter, runConfig = rc} = & maybe ( Right $ MkFilteredSuite - { suite = prepSuiteElm pp <$> filtered.suite, + { suite = prepSuiteElm interpreter rc <$> filtered.suite, filterResults = filtered.filterResults } ) Left where - pp = PrepParams interpreter rc filtered = filterSuite filters rc suite mSuiteError = chkSuite filtered.filterResults @@ -107,15 +106,12 @@ data Test m hi = MkTest action :: ApEventSink -> hi -> m () } -data PrepParams m rc fc where - PrepParams :: - { interpreter :: forall a. m a -> IO a, - runConfig :: rc - } -> - PrepParams m rc fc - -prepSuiteElm :: forall m rc fc hi. (HasCallStack, C.Config rc, C.Config fc) => PrepParams m rc fc -> C.Node m rc fc hi -> PreNode IO hi -prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = +prepSuiteElm :: forall m rc fc hi. (HasCallStack, C.Config rc, C.Config fc) => + (forall a. m a -> IO a ) -- interpreter + -> rc -- runConfig + -> C.Node m rc fc hi -- node + -> PreNode IO hi +prepSuiteElm interpreter rc suiteElm = suiteElm & \case C.Hook {hook, path, subNodes = subNodes'} -> hook & \case @@ -123,7 +119,8 @@ prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = Before { path, frequency, - action = \snk -> const . intprt snk $ action runConfig, + -- !!! HERE NEED TO WORK OUT HOW SINK IS TREADED TROUGH AND MAKE SURE INTEPRETOR USES IT + action = \snk -> const . intprt snk $ action rc, subNodes } C.Before' @@ -132,7 +129,7 @@ prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = Before { path, frequency, - action = \snk -> intprt snk . action' runConfig, + action = \snk -> intprt snk . action' rc, subNodes } C.After {afterAction} -> @@ -140,14 +137,14 @@ prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = { path, frequency, subNodes' = subNodes, - after = \snk -> intprt snk $ afterAction runConfig + after = \snk -> intprt snk $ afterAction rc } C.After' {afterAction'} -> After { path, frequency, subNodes' = subNodes, - after = \snk -> intprt snk $ afterAction' runConfig + after = \snk -> intprt snk $ afterAction' rc } C.Around { setup, @@ -156,9 +153,9 @@ prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = Around { path, frequency, - setup = \snk -> const . intprt snk $ setup runConfig, + setup = \snk -> const . intprt snk $ setup rc, subNodes, - teardown = \snk -> intprt snk . teardown runConfig + teardown = \snk -> intprt snk . teardown rc } C.Around' { setup', @@ -167,20 +164,20 @@ prepSuiteElm pp@PrepParams {interpreter, runConfig} suiteElm = Around { path, frequency, - setup = \snk -> intprt snk . setup' runConfig, + setup = \snk -> intprt snk . setup' rc, subNodes, - teardown = \snk -> intprt snk . teardown' runConfig + teardown = \snk -> intprt snk . teardown' rc } where frequency = C.hookFrequency hook subNodes = run <$> subNodes' run :: forall a. C.Node m rc fc a -> PreNode IO a - run = prepSuiteElm pp + run = prepSuiteElm interpreter rc intprt :: forall a. ApEventSink -> m a -> IO a intprt snk a = catchLog snk $ interpreter a - C.Fixture {path, fixture} -> prepareTest pp path fixture + C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture flog :: (HasCallStack) => ApEventSink -> FrameworkLog -> IO () flog sink = sink . Framework @@ -195,8 +192,11 @@ unTry :: forall a. ApEventSink -> Either SomeException a -> IO a unTry es = either (logThrow es) pure -prepareTest :: forall m rc fc hi. (C.Config fc) => PrepParams m rc fc -> Path -> C.Fixture m rc fc hi -> PreNode IO hi -prepareTest PrepParams {interpreter, runConfig} path = +prepareTest :: forall m rc fc hi. (C.Config fc) => + (forall a. m a -> IO a ) -- interpreter + -> rc -- runConfig + -> Path -> C.Fixture m rc fc hi -> PreNode IO hi +prepareTest interpreter rc path = \case C.Full {config, action, parse, items} -> Fixture @@ -207,10 +207,10 @@ prepareTest PrepParams {interpreter, runConfig} path = MkTest { id = i.id, title = i.title, - action = \snk _hi -> runTest (action runConfig) parse i snk + action = \snk _hi -> runTest (action rc) parse i snk } ) - <$> items runConfig + <$> items rc } C.Full' {config', action', parse', items'} -> Fixture @@ -221,10 +221,10 @@ prepareTest PrepParams {interpreter, runConfig} path = MkTest { id = i.id, title = i.title, - action = \snk hi -> runTest (action' runConfig hi) parse' i snk + action = \snk hi -> runTest (action' rc hi) parse' i snk } ) - <$> items' runConfig + <$> items' rc } C.Direct {config, action, items} -> Fixture @@ -235,10 +235,10 @@ prepareTest PrepParams {interpreter, runConfig} path = MkTest { id = i.id, title = i.title, - action = \snk _hi -> runDirectTest (action runConfig) i snk + action = \snk _hi -> runDirectTest (action rc) i snk } ) - <$> items runConfig + <$> items rc } C.Direct' {config', action', items'} -> Fixture @@ -249,10 +249,10 @@ prepareTest PrepParams {interpreter, runConfig} path = MkTest { id = i.id, title = i.title, - action = \snk hi -> runDirectTest (action' runConfig hi) i snk + action = \snk hi -> runDirectTest (action' rc hi) i snk } ) - <$> items' runConfig + <$> items' rc } where applyParser :: forall as ds. ((HasCallStack) => as -> Either C.ParseException ds) -> as -> Either SomeException ds diff --git a/test/SuiteRuntimeTest.hs b/test/SuiteRuntimeTest.hs index 68cc172d..4d2da8e8 100644 --- a/test/SuiteRuntimeTest.hs +++ b/test/SuiteRuntimeTest.hs @@ -65,7 +65,7 @@ unit_simple_fail :: IO () unit_simple_fail = runTest defaultSeed (ThreadCount 1) [onceAround Fail Pass [fixture [test Pass, test Fail]]] --- $> unit_nested_pass_fail +-- >>> unit_nested_pass_fail unit_nested_pass_fail :: IO () unit_nested_pass_fail = runTest diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index 9c2c5149..f499f496 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -99,7 +99,7 @@ bug :: Text -> a bug t = PR.bug (error t :: SomeException) logging :: Logging -logging = LogFails +logging = Log {- each and once hooks will always run but thread hooks may be empty due to subitems being stolen by another thread. We need to ensure @@ -889,7 +889,7 @@ execute wantLog baseRandomSeed threadLimit templates = do exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [Log ExePath AE.NodeEvent] exeTemplate wantLog baseRandomSeed maxThreads templates = do let wantLog' = wantLog == Log - (lc, logQ) <- testLogControls wantLog' + (lc, logLst) <- testLogControls wantLog' when (wantLog' || wantLog == LogTemplate) $ do putStrLn "#### Template ####" pPrint templates @@ -901,15 +901,7 @@ exeTemplate wantLog baseRandomSeed maxThreads templates = do putStrLn "=========" putStrLn "#### Log ####" executeWithoutValidation maxThreads lc nodes - atomically $ q2List logQ - -q2List :: TQueue a -> STM [a] -q2List qu = reverse <$> recurse [] qu - where - recurse :: [a] -> TQueue a -> STM [a] - recurse l q = - tryReadTQueue q - >>= maybe (pure l) (\e -> recurse (e : l) q) + atomically logLst loadTQueue :: TQueue a -> [a] -> STM () loadTQueue q = traverse_ (writeTQueue q) From 306fa29e81fcd55a7b146b57866f9ce63ef0e225 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 17 Sep 2024 20:27:51 +0000 Subject: [PATCH 03/43] rename ApEventSink -> LogSink --- src/Internal/SuiteRuntime.hs | 40 ++++++++++++++++++------------------ src/Prepare.hs | 32 ++++++++++++++--------------- test/SuiteRuntimeTestBase.hs | 2 +- 3 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index b49c809a..fa1c1311 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -82,7 +82,7 @@ executeNodes L.MkLoggerSource {rootLogger, newLogger} nodes tc = data ExeTree hi where OnceBefore :: { path :: L.ExePath, - before :: P.ApEventSink -> hi -> IO ho, + before :: P.LogSink -> hi -> IO ho, beforeStatus :: TVar BeforeStatus, cache :: TMVar (Either L.FailPoint ho), subNodes :: ChildQ (ExeTree ho) @@ -90,56 +90,56 @@ data ExeTree hi where ExeTree hi OnceAround :: { path :: L.ExePath, - setup :: P.ApEventSink -> hi -> IO ho, + setup :: P.LogSink -> hi -> IO ho, status :: TVar AroundStatus, cache :: TMVar (Either L.FailPoint ho), subNodes :: ChildQ (ExeTree ho), - teardown :: P.ApEventSink -> ho -> IO () + teardown :: P.LogSink -> ho -> IO () } -> ExeTree hi OnceAfter :: { path :: L.ExePath, status' :: TVar AfterStatus, subNodes' :: ChildQ (ExeTree hi), - after :: P.ApEventSink -> IO () + after :: P.LogSink -> IO () } -> ExeTree hi ThreadBefore :: { path :: L.ExePath, - before :: P.ApEventSink -> hi -> IO ho, + before :: P.LogSink -> hi -> IO ho, subNodes :: ChildQ (ExeTree ho) } -> ExeTree hi ThreadAround :: { path :: L.ExePath, - setup :: P.ApEventSink -> hi -> IO ho, + setup :: P.LogSink -> hi -> IO ho, subNodes :: ChildQ (ExeTree ho), - teardown :: P.ApEventSink -> ho -> IO () + teardown :: P.LogSink -> ho -> IO () } -> ExeTree hi ThreadAfter :: { path :: L.ExePath, subNodes' :: ChildQ (ExeTree hi), - after :: P.ApEventSink -> IO () + after :: P.LogSink -> IO () } -> ExeTree hi EachBefore :: { path :: L.ExePath, - before :: P.ApEventSink -> hi -> IO ho, + before :: P.LogSink -> hi -> IO ho, subNodes :: ChildQ (ExeTree ho) } -> ExeTree hi EachAround :: { path :: L.ExePath, - setup :: P.ApEventSink -> hi -> IO ho, + setup :: P.LogSink -> hi -> IO ho, subNodes :: ChildQ (ExeTree ho), - teardown :: P.ApEventSink -> ho -> IO () + teardown :: P.LogSink -> ho -> IO () } -> ExeTree hi EachAfter :: { path :: L.ExePath, subNodes' :: ChildQ (ExeTree hi), - after :: P.ApEventSink -> IO () + after :: P.LogSink -> IO () } -> ExeTree hi Fixture :: @@ -581,10 +581,10 @@ runNode :: runNode lgr hi xt = run hi xt where - logRun' :: NodeType -> (P.ApEventSink -> IO b) -> IO (Either L.FailPoint b) + logRun' :: NodeType -> (P.LogSink -> IO b) -> IO (Either L.FailPoint b) logRun' et action = logRun lgr xt.path et (action sink) - logRun_ :: NodeType -> (P.ApEventSink -> IO b) -> IO () + logRun_ :: NodeType -> (P.LogSink -> IO b) -> IO () logRun_ et action = void $ logRun' et action logAbandonned_ :: NodeType -> L.FailPoint -> IO () @@ -607,7 +607,7 @@ runNode lgr hi xt = invalidTree :: Text -> Text -> IO QElementRun invalidTree input cst = bug @Void . error $ input <> " >>> should not be passed to >>> " <> cst <> "\n" <> txt xt.path - sink :: P.ApEventSink + sink :: P.LogSink sink = lgr . L.NodeEvent runTestsWithEachContext :: forall ti. IO (TestContext ti) -> TestSource ti -> IO QElementRun @@ -692,25 +692,25 @@ runNode lgr hi xt = singleton' :: forall a. TMVar a -> IO a -> a -> IO a singleton' tCache ioa = const $ singleton tCache ioa - runThreadSetup :: forall i o. TMVar (Either L.FailPoint o) -> NodeType -> (P.ApEventSink -> i -> IO o) -> Either L.FailPoint i -> IO (Either L.FailPoint o) + runThreadSetup :: forall i o. TMVar (Either L.FailPoint o) -> NodeType -> (P.LogSink -> i -> IO o) -> Either L.FailPoint i -> IO (Either L.FailPoint o) runThreadSetup tCache evnt setup eti = do -- a singleton to avoid running empty subnodes (could happen if another thread finishes child list) -- no need for thread synchronisation as this happpens within a thread singleton tCache $ runSetup evnt setup eti - runSetup :: forall i o. NodeType -> (P.ApEventSink -> i -> IO o) -> Either L.FailPoint i -> IO (Either L.FailPoint o) + runSetup :: forall i o. NodeType -> (P.LogSink -> i -> IO o) -> Either L.FailPoint i -> IO (Either L.FailPoint o) runSetup evnt setup = either (logAbandonned' evnt) (logRun' evnt . flip setup) - runThreadTeardown :: forall i. TMVar (Either L.FailPoint i) -> (P.ApEventSink -> i -> IO ()) -> IO () + runThreadTeardown :: forall i. TMVar (Either L.FailPoint i) -> (P.LogSink -> i -> IO ()) -> IO () runThreadTeardown = runPostThread L.Teardown - runThreadAfter :: TMVar (Either L.FailPoint ()) -> (P.ApEventSink -> IO ()) -> IO () + runThreadAfter :: TMVar (Either L.FailPoint ()) -> (P.LogSink -> IO ()) -> IO () runThreadAfter tCache after = runPostThread L.After tCache (\s _i -> after s) - runPostThread :: forall i. HookPos -> TMVar (Either L.FailPoint i) -> (P.ApEventSink -> i -> IO ()) -> IO () + runPostThread :: forall i. HookPos -> TMVar (Either L.FailPoint i) -> (P.LogSink -> i -> IO ()) -> IO () runPostThread hp tCache teardown = do -- unless () mho <- atomically $ tryReadTMVar tCache diff --git a/src/Prepare.hs b/src/Prepare.hs index d36feb15..7c6171d7 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -2,7 +2,7 @@ module Prepare ( PreNode (..), - ApEventSink, + LogSink, Test (..), prepare, listPaths, @@ -54,7 +54,7 @@ data PreNode m hi where Before :: { path :: Path, frequency :: Hz, - action :: ApEventSink -> hi -> m o, + action :: LogSink -> hi -> m o, subNodes :: [PreNode m o] } -> PreNode m hi @@ -62,15 +62,15 @@ data PreNode m hi where { path :: Path, frequency :: Hz, subNodes' :: [PreNode m hi], - after :: ApEventSink -> m () + after :: LogSink -> m () } -> PreNode m hi Around :: { path :: Path, frequency :: Hz, - setup :: ApEventSink -> hi -> m o, + setup :: LogSink -> hi -> m o, subNodes :: [PreNode m o], - teardown :: ApEventSink -> o -> m () + teardown :: LogSink -> o -> m () } -> PreNode m hi Fixture :: @@ -81,7 +81,7 @@ data PreNode m hi where } -> PreNode m hi -type ApEventSink = NodeEvent -> IO () +type LogSink = NodeEvent -> IO () -- used in debugging listPaths :: forall m hi. PreNode m hi -> [(Int, Path)] @@ -103,7 +103,7 @@ listPaths = data Test m hi = MkTest { id :: Int, title :: Text, - action :: ApEventSink -> hi -> m () + action :: LogSink -> hi -> m () } prepSuiteElm :: forall m rc fc hi. (HasCallStack, C.Config rc, C.Config fc) => @@ -175,20 +175,20 @@ prepSuiteElm interpreter rc suiteElm = run :: forall a. C.Node m rc fc a -> PreNode IO a run = prepSuiteElm interpreter rc - intprt :: forall a. ApEventSink -> m a -> IO a + intprt :: forall a. LogSink -> m a -> IO a intprt snk a = catchLog snk $ interpreter a C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture -flog :: (HasCallStack) => ApEventSink -> FrameworkLog -> IO () +flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () flog sink = sink . Framework -catchLog :: forall a. (HasCallStack) => ApEventSink -> IO a -> IO a +catchLog :: forall a. (HasCallStack) => LogSink -> IO a -> IO a catchLog as io = tryAny io >>= either (logThrow as) pure -logThrow :: (HasCallStack) => ApEventSink -> SomeException -> IO a +logThrow :: (HasCallStack) => LogSink -> SomeException -> IO a logThrow sink ex = sink (exceptionEvent ex callStack) >> throwIO ex -unTry :: forall a. ApEventSink -> Either SomeException a -> IO a +unTry :: forall a. LogSink -> Either SomeException a -> IO a unTry es = either (logThrow es) pure @@ -258,13 +258,13 @@ prepareTest interpreter rc path = applyParser :: forall as ds. ((HasCallStack) => as -> Either C.ParseException ds) -> as -> Either SomeException ds applyParser parser as = mapLeft toException $ parser as - runAction :: forall i as ds. (C.Item i ds) => ApEventSink -> (i -> m as) -> i -> IO as + runAction :: forall i as ds. (C.Item i ds) => LogSink -> (i -> m as) -> i -> IO as runAction snk action i = do flog snk . Action path . ItemText $ txt i catchLog snk . interpreter $ action i - runTest :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> ((HasCallStack) => as -> Either C.ParseException ds) -> i -> ApEventSink -> IO () + runTest :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> ((HasCallStack) => as -> Either C.ParseException ds) -> i -> LogSink -> IO () runTest action parser i snk = do ds <- tryAny @@ -274,11 +274,11 @@ prepareTest interpreter rc path = unTry snk $ applyParser parser as applyChecks snk path i.checks ds - runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> ApEventSink -> IO () + runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> LogSink -> IO () runDirectTest action i snk = tryAny (runAction snk action i) >>= applyChecks snk path i.checks -applyChecks :: forall ds. (Show ds) => ApEventSink -> Path -> Checks ds -> Either SomeException ds -> IO () +applyChecks :: forall ds. (Show ds) => LogSink -> Path -> Checks ds -> Either SomeException ds -> IO () applyChecks snk p chks = either ( \e -> do diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index f499f496..14486161 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -1113,7 +1113,7 @@ mkVoidAction path spec = -- TODO: make bug / error functions that uses text instead of string -- TODO: check callstack -mkAction :: forall hi pth. (Show pth) => pth -> Spec -> P.ApEventSink -> hi -> IO () +mkAction :: forall hi pth. (Show pth) => pth -> Spec -> P.LogSink -> hi -> IO () mkAction path s _sink _in = mkVoidAction path s mkNodes :: Int -> ThreadCount -> [T.Template] -> IO [P.PreNode IO ()] From 4d6ecdf5419d9baf32516aa8d7fa82342bd99aef Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 17 Sep 2024 21:14:10 +0000 Subject: [PATCH 04/43] got compiling --- examples/DocumenterDemo.hs | 12 ++++++------ examples/FileSystemDocDemo.hs | 4 +++- examples/IOEffectDemo.hs | 4 ++-- examples/PyrethrumBase.hs | 16 ++++++++-------- examples/PyrethrumDemoTest.hs | 2 +- examples/WebDriverDemo.hs | 2 +- examples/WebDriverDocInterpreter.hs | 2 +- pyrethrum.cabal | 7 +++---- src/Core.hs | 2 +- src/DSL/DocInterpreterUtils.hs | 2 +- src/DSL/FileSystemDocInterpreter.hs | 2 +- src/DSL/Internal/NodeEvent.hs | 1 + src/DSL/{Out.hs => OutEffect.hs} | 12 ++---------- src/DSL/OutInterpreter.hs | 14 ++++++++++++++ src/Internal/OutDocInterpreter.hs | 20 -------------------- src/Internal/OutIOInterpreter.hs | 21 --------------------- src/Prepare.hs | 12 +++++------- 17 files changed, 50 insertions(+), 85 deletions(-) rename src/DSL/{Out.hs => OutEffect.hs} (75%) create mode 100644 src/DSL/OutInterpreter.hs delete mode 100644 src/Internal/OutDocInterpreter.hs delete mode 100644 src/Internal/OutIOInterpreter.hs diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index d3277604..81209738 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -6,8 +6,8 @@ import Check import Core (ParseException) import DSL.FileSystemDocInterpreter qualified as FDoc import DSL.FileSystemEffect -import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) -import DSL.Out (Out, out) +import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log), LogSink) +import DSL.OutEffect (Out, out) import Data.Text (isInfixOf) import Effectful as EF ( Eff, @@ -31,7 +31,6 @@ import PyrethrumBase DataSource(ItemList), Depth(DeepRegression), defaultRunConfig, - runDocOut, docRunner ) import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) import WebDriverEffect @@ -47,6 +46,7 @@ import WebDriverEffect killSession ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) +import DSL.OutInterpreter (runOut) runDemo :: SuiteRunner -> Suite -> IO () @@ -92,13 +92,13 @@ fsDemoAp = do paths <- getPaths chkPathsThatDoesNothing paths -fsDocDemoSimple :: IO () -fsDocDemoSimple = +fsDocDemoSimple :: LogSink -> IO () +fsDocDemoSimple sink = -- docInterpreter fsDemoAp docRun fsDemoAp where docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a - docRun = runEff . runDocOut . FDoc.runFileSystem + docRun = runEff . runOut sink . FDoc.runFileSystem -- >>> fsDocDemoSimple diff --git a/examples/FileSystemDocDemo.hs b/examples/FileSystemDocDemo.hs index 94c0ff64..7c98c24d 100644 --- a/examples/FileSystemDocDemo.hs +++ b/examples/FileSystemDocDemo.hs @@ -7,7 +7,8 @@ import DSL.FileSystemEffect walkDirAccum, ) import DSL.Internal.NodeEvent (NodeEvent (User), UserLog (Log)) -import DSL.Out (Out, Sink (Sink), out, runOut) +import DSL.OutEffect (Out, Sink (Sink), out) +import DSL.OutInterpreter ( runOut ) import Data.List.Extra (isInfixOf) import Effectful (Eff, IOE, runEff, (:>)) import Path (Abs, File, Path, absdir, reldir, relfile, toFilePath) @@ -15,6 +16,7 @@ import PyrethrumExtras ((?)) type FSOut es = (Out NodeEvent :> es, FileSystem :> es) + -- todo - use a more believable base function demo :: forall es. (FSOut es) => Eff es () demo = do diff --git a/examples/IOEffectDemo.hs b/examples/IOEffectDemo.hs index 8c225a76..ad85df72 100644 --- a/examples/IOEffectDemo.hs +++ b/examples/IOEffectDemo.hs @@ -5,7 +5,8 @@ import Chronos (Time, now) import DSL.FileSystemEffect ( walkDirAccum ) import Effectful ( IOE, type (:>), Eff, runEff ) -import DSL.Out +import DSL.OutEffect +import DSL.OutInterpreter ( runOut ) import DSL.Internal.NodeEvent import Data.Text qualified as T import BasePrelude (openFile, hClose, hGetContents) @@ -13,7 +14,6 @@ import DSL.FileSystemIOInterpreter ( FileSystem, runFileSystem ) import System.Time.Extra (sleep) import PyrethrumExtras.IO (putTxt) - {- \************************************************************ \************ standard haskell laziness examples ************ diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index fe5b5b9f..f96b00ac 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -17,7 +17,6 @@ module PyrethrumBase mkCoreSuite, ioRunner, docRunner, - runDocOut, defaultRunConfig, docInterpreter ) @@ -29,7 +28,8 @@ import DSL.FileSystemEffect (FileSystem) import DSL.FileSystemIOInterpreter qualified as FIO (runFileSystem) import DSL.Internal.NodeEvent (NodeEvent) import DSL.Internal.NodeEvent qualified as AE -import DSL.Out (Out, runOut) +import DSL.OutEffect (Out) +import DSL.OutInterpreter ( runOut ) import Effectful (Eff, IOE, runEff, type (:>)) import Filter (Filters) import Internal.Logging qualified as L @@ -67,12 +67,12 @@ type ApEffs = '[FileSystem, WebUI, Out NodeEvent, IOE] type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () -ioInterpreter :: Action a -> IO a -ioInterpreter ap = +ioInterpreter :: AE.LogSink -> Action a -> IO a +ioInterpreter sink ap = ap & FIO.runFileSystem & WDIO.runWebDriver - & runIOOut + & runOut sink & runEff @@ -112,12 +112,12 @@ ioRunner suite filters runConfig threadCount logControls = runConfig } -docInterpreter :: Action a -> IO a -docInterpreter ap = +docInterpreter :: AE.LogSink -> Action a -> IO a +docInterpreter sink ap = ap & FDoc.runFileSystem & WDDoc.runWebDriver - & runDocOut + & runOut sink & runEff diff --git a/examples/PyrethrumDemoTest.hs b/examples/PyrethrumDemoTest.hs index eca8c745..a3a16f9d 100644 --- a/examples/PyrethrumDemoTest.hs +++ b/examples/PyrethrumDemoTest.hs @@ -3,7 +3,7 @@ module PyrethrumDemoTest where import Check (Checks, chk) import Core (After, Around, Before, Each, Once, ParseException, Thread) import DSL.Internal.NodeEvent (NodeEvent (..), Path (..), UserLog (Log)) -import DSL.Out (out) +import DSL.OutEffect (out) import Effectful (Eff) import PyrethrumBase ( Action, diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index d28a3d30..e00c76b6 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -3,7 +3,7 @@ module WebDriverDemo where import Check import Core (ParseException) import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) -import DSL.Out (Out, out) +import DSL.OutEffect (Out, out) import Effectful as EF ( Eff, type (:>), diff --git a/examples/WebDriverDocInterpreter.hs b/examples/WebDriverDocInterpreter.hs index 193fe9a0..5199a986 100644 --- a/examples/WebDriverDocInterpreter.hs +++ b/examples/WebDriverDocInterpreter.hs @@ -17,7 +17,7 @@ import Effectful.Dispatch.Dynamic import WebDriverEffect (WebUI (..)) import DSL.DocInterpreterUtils (docErr, docErr2) import DSL.Internal.NodeEvent (NodeEvent) -import DSL.Out ( Out ) +import DSL.OutEffect ( Out ) import PyrethrumExtras (txt) runWebDriver :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Eff (WebUI : es) a -> Eff es a diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 453e49ce..608c5c9b 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: 51fa65cc469499e2950ccd8a46ec67a71dc18e4925baf5eee83cfaf49f730427 +-- hash: 3ef7573ce099bebdb3230f0e91740c75b087ab0958eb134b76b17d4ea94f4921 name: pyrethrum version: 0.1.0.0 @@ -89,13 +89,12 @@ library DSL.Internal.FileSystemIO DSL.Internal.FileSystemPure DSL.Internal.NodeEvent - DSL.Out + DSL.OutEffect + DSL.OutInterpreter Filter Internal.Logging Internal.LoggingCore Internal.LogQueries - Internal.OutDocInterpreter - Internal.OutIOInterpreter Internal.SuiteFiltering Internal.SuiteRuntime Internal.SuiteValidation diff --git a/src/Core.hs b/src/Core.hs index aeb2d7dd..d1ab4e83 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -202,7 +202,7 @@ data SuiteExeParams m rc fc where MkSuiteExeParams :: { suite :: [Node m rc fc ()], filters :: Filters rc fc, - interpreter :: forall a. m a -> IO a, + interpreter :: forall a. LogSink -> m a -> IO a, runConfig :: rc } -> SuiteExeParams m rc fc diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index 4356728c..b886bc7d 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -9,7 +9,7 @@ module DSL.DocInterpreterUtils ( docErrn' ) where -import DSL.Out ( out, Out ) +import DSL.OutEffect ( out, Out ) import Effectful as EF ( Eff, IOE, diff --git a/src/DSL/FileSystemDocInterpreter.hs b/src/DSL/FileSystemDocInterpreter.hs index e29d5234..59910b35 100644 --- a/src/DSL/FileSystemDocInterpreter.hs +++ b/src/DSL/FileSystemDocInterpreter.hs @@ -4,7 +4,7 @@ module DSL.FileSystemDocInterpreter ( runFileSystem, ) where -import DSL.Out ( Out ) +import DSL.OutEffect ( Out ) import Effectful as EF ( Eff, IOE, diff --git a/src/DSL/Internal/NodeEvent.hs b/src/DSL/Internal/NodeEvent.hs index 9bb6a68e..f71a5059 100644 --- a/src/DSL/Internal/NodeEvent.hs +++ b/src/DSL/Internal/NodeEvent.hs @@ -4,6 +4,7 @@ import Check (CheckReport) import Data.Aeson.TH (defaultOptions, deriveJSON) import PyrethrumExtras (toS) +type LogSink = NodeEvent -> IO () -- TODO: Note plugin {- NodeEvent is a data type that represents events emitted by or from WITHIN a node (ie. a Hook or a Fixture) diff --git a/src/DSL/Out.hs b/src/DSL/OutEffect.hs similarity index 75% rename from src/DSL/Out.hs rename to src/DSL/OutEffect.hs index b2cfd50a..91db8095 100644 --- a/src/DSL/Out.hs +++ b/src/DSL/OutEffect.hs @@ -2,12 +2,7 @@ {-# LANGUAGE NoPolyKinds #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module DSL.Out ( - Out, - Sink (..), - out, - runOut -) where +module DSL.OutEffect where import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>)) import Effectful.Dispatch.Static (StaticRep, SideEffects(..), getStaticRep, unsafeEff_, evalStaticRep) @@ -27,7 +22,4 @@ newtype Sink a = Sink {sink :: a -> IO ()} out :: (Out a :> es) => a -> Eff es () out payload = do Out s <- getStaticRep - unsafeEff_ . s.sink $ payload - -runOut :: (IOE :> es) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es b -runOut = evalStaticRep . Out . Sink + unsafeEff_ . s.sink $ payload \ No newline at end of file diff --git a/src/DSL/OutInterpreter.hs b/src/DSL/OutInterpreter.hs new file mode 100644 index 00000000..812f1eeb --- /dev/null +++ b/src/DSL/OutInterpreter.hs @@ -0,0 +1,14 @@ +-- TODO - Why do I to need this? +{-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module DSL.OutInterpreter ( + runOut +) where + +import DSL.OutEffect as OE +import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>)) +import Effectful.Dispatch.Static (StaticRep, SideEffects(..), getStaticRep, unsafeEff_, evalStaticRep) + +runOut :: (IOE :> es) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es b +runOut = evalStaticRep . Out . Sink diff --git a/src/Internal/OutDocInterpreter.hs b/src/Internal/OutDocInterpreter.hs deleted file mode 100644 index a6b2c806..00000000 --- a/src/Internal/OutDocInterpreter.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Internal.OutDocInterpreter where - --- Import necessary modules -import Data.Text (Text) -import Effectful as EF - ( Eff, - IOE, - runEff, - type (:>), - ) -import DSL.Internal.NodeEvent as AE -import DSL.Out - --- !!!! This is wrong --- in doc mode we supress log -runDocOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a -runDocOut = - runOut $ \case - AE.Framework l -> print l - AE.User _l -> pure () diff --git a/src/Internal/OutIOInterpreter.hs b/src/Internal/OutIOInterpreter.hs deleted file mode 100644 index 024f14eb..00000000 --- a/src/Internal/OutIOInterpreter.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Internal.OutIOInterpreter where - --- Import necessary modules -import Data.Text (Text) -import Effectful as EF - ( Eff, - IOE, - runEff, - type (:>), - ) -import DSL.Internal.NodeEvent as AE -import DSL.Out - --- Define your functions and types here - --- TODO - interpreters into own module --- Need to fix up to work in with logcontrols --- there are currently 2 paths to STD out I think ?? --- this is wrong -runIOOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a -runIOOut = runOut print diff --git a/src/Prepare.hs b/src/Prepare.hs index 7c6171d7..c1b57f06 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -23,7 +23,7 @@ import DSL.Internal.NodeEvent ItemText (ItemText), NodeEvent (Framework), Path, - exceptionEvent, + exceptionEvent, LogSink, ) import Data.Either.Extra (mapLeft) import Internal.SuiteFiltering (FilteredSuite (..), filterSuite) @@ -81,8 +81,6 @@ data PreNode m hi where } -> PreNode m hi -type LogSink = NodeEvent -> IO () - -- used in debugging listPaths :: forall m hi. PreNode m hi -> [(Int, Path)] listPaths = @@ -107,7 +105,7 @@ data Test m hi = MkTest } prepSuiteElm :: forall m rc fc hi. (HasCallStack, C.Config rc, C.Config fc) => - (forall a. m a -> IO a ) -- interpreter + (forall a. LogSink -> m a -> IO a ) -- interpreter -> rc -- runConfig -> C.Node m rc fc hi -- node -> PreNode IO hi @@ -176,7 +174,7 @@ prepSuiteElm interpreter rc suiteElm = run = prepSuiteElm interpreter rc intprt :: forall a. LogSink -> m a -> IO a - intprt snk a = catchLog snk $ interpreter a + intprt snk a = catchLog snk $ interpreter snk a C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () @@ -193,7 +191,7 @@ unTry es = either (logThrow es) pure prepareTest :: forall m rc fc hi. (C.Config fc) => - (forall a. m a -> IO a ) -- interpreter + (forall a. LogSink -> m a -> IO a ) -- interpreter -> rc -- runConfig -> Path -> C.Fixture m rc fc hi -> PreNode IO hi prepareTest interpreter rc path = @@ -262,7 +260,7 @@ prepareTest interpreter rc path = runAction snk action i = do flog snk . Action path . ItemText $ txt i - catchLog snk . interpreter $ action i + catchLog snk . interpreter snk $ action i runTest :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> ((HasCallStack) => as -> Either C.ParseException ds) -> i -> LogSink -> IO () runTest action parser i snk = From 32b2a13e32e0922083c039cbf4dcf33f3797f11e Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 17 Sep 2024 21:28:45 +0000 Subject: [PATCH 05/43] WIP --- examples/DocumenterDemo.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 81209738..6d3bc40a 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -51,10 +51,10 @@ import DSL.OutInterpreter (runOut) runDemo :: SuiteRunner -> Suite -> IO () runDemo runner suite = do - (logControls, logList) <- L.testLogControls True + (logControls, _logList) <- L.testLogControls True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls - putStrLn "########## Log ##########" - atomically logList >>= mapM_ pPrint + -- putStrLn "########## Log ##########" + -- atomically logList >>= mapM_ pPrint -- ############### Test Case ################### @@ -100,17 +100,23 @@ fsDocDemoSimple sink = docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a docRun = runEff . runOut sink . FDoc.runFileSystem +-- TODO:: FIX -- >>> fsDocDemoSimple +-- No instance for `Show (LogSink -> IO ())' +-- arising from a use of `evalPrint' +-- (maybe you haven't applied a function to enough arguments?) +-- In a stmt of an interactive GHCi command: evalPrint it_a1YYG -- ################### 2. FS App with full runtime ################## {- OH THE HUMANITY !!! -1. log scrambling +1. log scrambling z:: FIXED 1.1 - take unhandled excption out of the picture in demo - FAILED STILL SCRABLED 1.2 - switch off filter log (execute -> executeWithoutValidation) - FAILED STILL SCRABLED - 1.3 - log outfull channel + 1.3 - log outfull channel :: FIXED with use of proper interpreter 2. exception not handled + - reinstate exception for doc 3. laziness not working -} @@ -132,7 +138,7 @@ getFail = pure $ error "This is an error !!! " fsAction :: (FileSystem :> es, Out NodeEvent :> es) => RunConfig -> FSData -> Eff es FSAS fsAction _rc i = do - -- getFail + getFail paths <- getPaths log i.title chkPathsThatDoesNothing paths From 4da8d08ddb0738cd2a8e16ff6536c0a85f9d288c Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 02:58:01 +0000 Subject: [PATCH 06/43] WIP --- examples/DocumenterDemo.hs | 59 ++++++++++++++--------------- examples/PyrethrumBase.hs | 1 - src/DSL/DocInterpreterUtils.hs | 53 ++++++++++---------------- src/DSL/FileSystemDocInterpreter.hs | 16 +++----- src/DSL/OutEffect.hs | 4 +- src/DSL/OutInterpreter.hs | 4 +- src/Internal/Logging.hs | 2 - src/Internal/SuiteRuntime.hs | 20 +++++----- src/Prepare.hs | 17 +++++++-- 9 files changed, 84 insertions(+), 92 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 6d3bc40a..31fe2ba3 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -4,21 +4,17 @@ module DocumenterDemo where import Check import Core (ParseException) -import DSL.FileSystemDocInterpreter qualified as FDoc import DSL.FileSystemEffect -import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log), LogSink) +import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) import DSL.OutEffect (Out, out) import Data.Text (isInfixOf) import Effectful as EF ( Eff, - IOE, - runEff, type (:>), ) import Filter (Filters (..)) import Internal.Logging qualified as L import Internal.SuiteRuntime (ThreadCount (..)) -import Text.Show.Pretty (pPrint) import Path as P (Path, reldir, toFilePath) import PyrethrumBase ( SuiteRunner, @@ -46,7 +42,6 @@ import WebDriverEffect killSession ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) -import DSL.OutInterpreter (runOut) runDemo :: SuiteRunner -> Suite -> IO () @@ -56,6 +51,9 @@ runDemo runner suite = do -- putStrLn "########## Log ##########" -- atomically logList >>= mapM_ pPrint +docDemo :: Suite -> IO () +docDemo = runDemo docRunner + -- ############### Test Case ################### -- TODO: repeated code - refactor @@ -81,7 +79,6 @@ getPaths = isDeleteMe :: P.Path Abs File -> Eff es Bool isDeleteMe = pure . isInfixOf "deleteMe" . toS . P.toFilePath --- ######## 1. This has the behaviour we are after with a simple local interpreter ######## chkPathsThatDoesNothing :: [P.Path Abs File] -> Eff es () chkPathsThatDoesNothing _ = pure () @@ -92,22 +89,8 @@ fsDemoAp = do paths <- getPaths chkPathsThatDoesNothing paths -fsDocDemoSimple :: LogSink -> IO () -fsDocDemoSimple sink = - -- docInterpreter fsDemoAp - docRun fsDemoAp - where - docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a - docRun = runEff . runOut sink . FDoc.runFileSystem - --- TODO:: FIX --- >>> fsDocDemoSimple --- No instance for `Show (LogSink -> IO ())' --- arising from a use of `evalPrint' --- (maybe you haven't applied a function to enough arguments?) --- In a stmt of an interactive GHCi command: evalPrint it_a1YYG --- ################### 2. FS App with full runtime ################## +-- ################### 1. FS App with full runtime ################## {- OH THE HUMANITY !!! @@ -116,12 +99,14 @@ OH THE HUMANITY !!! 1.2 - switch off filter log (execute -> executeWithoutValidation) - FAILED STILL SCRABLED 1.3 - log outfull channel :: FIXED with use of proper interpreter 2. exception not handled - - reinstate exception for doc + - reinstate exception for doc :: DONE + - its the lazy logging !!! 3. laziness not working + - need special handling for docmode -} fsSuiteDemo :: IO () -fsSuiteDemo = runDemo docRunner fsSuite +fsSuiteDemo = docDemo fsSuite -- >>> fsSuiteDemo @@ -133,15 +118,20 @@ fsSuite = fstest :: Fixture () fstest = Full config fsAction parsefs fsItems +getFailNested :: Eff es FSAS +getFailNested = pure $ error "This is a nested error !!! " + getFail :: Eff es FSAS -getFail = pure $ error "This is an error !!! " +getFail = error "This is an error !!! " fsAction :: (FileSystem :> es, Out NodeEvent :> es) => RunConfig -> FSData -> Eff es FSAS fsAction _rc i = do - getFail + getFailNested + -- getFail paths <- getPaths log i.title chkPathsThatDoesNothing paths + log "Paths checked ~ not really" pure $ FSAS {paths} data FSData = FSItem @@ -162,7 +152,7 @@ data FSData = FSItem -} -newtype FSAS = FSAS +data FSAS = FSAS { paths :: [P.Path Abs File] } deriving (Show) @@ -192,7 +182,11 @@ fsItems _rc = docWebDriverDemo :: IO () docWebDriverDemo = runDemo docRunner webDriverSuite --- >>> docWebDriverDemo +-- $> docWebDriverDemo +-- *** Exception: +-- Exception thrown in step documentation. +-- Value forced from function: 'driverStatus' in documentation mode. +-- Use docVal, docHush, docVoid, docVal' to replace or silence this value from where the step is called: 'driverStatus' webDriverSuite :: Suite webDriverSuite = @@ -207,7 +201,8 @@ config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus driver_status = do status <- driverStatus "NA" - log $ "the driver status is: " <> txt status + log "Forcing driver status" + log $ "the driver status is (from driver status): " <> txt status pure status _theInternet :: Text @@ -216,11 +211,13 @@ _theInternet = "https://the-internet.herokuapp.com/" _checkBoxesLinkCss :: Selector _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" + action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS action _rc i = do - log i.title + log $ "test title is: " <> i.title + error "BANG" status <- driver_status - log $ "the driver status is: " <> txt status + log $ "the driver status is (from root): " <> txt status ses <- newSession maximiseWindow ses go ses _theInternet diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index f96b00ac..101825de 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -48,7 +48,6 @@ import WebDriverDocInterpreter qualified as WDDoc (runWebDriver) import WebDriverEffect (WebUI (..)) import WebDriverIOInterpreter qualified as WDIO (runWebDriver) import Prepare (prepare, PreNode) -import PyrethrumExtras (txt) import Internal.SuiteValidation (SuiteValidationError) import Internal.SuiteFiltering (FilteredSuite(..)) diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index b886bc7d..04c775dd 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -1,23 +1,22 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module DSL.DocInterpreterUtils ( - docErr, - docErr2, - docErr3, - docErr4, - docErrn, - docErrn' -) where +module DSL.DocInterpreterUtils + ( docErr, + docErr2, + docErr3, + docErr4, + docErrn, + ) +where -import DSL.OutEffect ( out, Out ) -import Effectful as EF ( - Eff, - IOE, - type (:>), - ) - -import DSL.Internal.NodeEvent (NodeEvent (..), FrameworkLog (Step)) +import DSL.Internal.NodeEvent (FrameworkLog (Step), NodeEvent (..)) +import DSL.OutEffect (Out, out) import Data.Text qualified as T +import Effectful as EF + ( Eff, + IOE, + type (:>), + ) {- data DocException @@ -46,7 +45,7 @@ adaptException m = EF.liftIO m `catch` \(e :: SomeException) -> E.throwError . D logStep :: (Out NodeEvent :> es) => Text -> Eff es () logStep = out . Framework . Step -docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> [Text] -> Eff es a +docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> [Text] -> Eff es a docErrn funcName dscFrags = do let funcDesc = T.intercalate " " dscFrags @@ -54,8 +53,7 @@ docErrn funcName dscFrags = -- TODO :: replace this later when have code to process call -- stack right now out of the box call handling looks better -- E.throwError . DocException $ - pure $ error "" - {- + -- pure $ error "" pure . error $ "\nException thrown in step documentation." <> "\n Value forced from function: '" @@ -65,24 +63,15 @@ docErrn funcName dscFrags = <> " to replace or silence this value from where the step is called: '" <> funcName <> "'" - -} - -docErrn' :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> [Text] -> a -> Eff es a -docErrn' funcName dscFrags mockValue = - do - let funcDesc = T.intercalate " " dscFrags - logStep funcDesc - pure mockValue - -docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> Text -> Eff es a +docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Eff es a docErr funcName funcDesc = docErrn funcName [funcDesc] -docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> Text -> Text -> Eff es a +docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Eff es a docErr2 funcName funcDesc1 funcDesc2 = docErrn funcName [funcDesc1, funcDesc2] -docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Eff es a +docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Eff es a docErr3 funcName funcDesc1 funcDesc2 funcDesc3 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3] -docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Text -> Eff es a +docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Text -> Eff es a docErr4 funcName funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3, funcDesc4] diff --git a/src/DSL/FileSystemDocInterpreter.hs b/src/DSL/FileSystemDocInterpreter.hs index 59910b35..454efbd2 100644 --- a/src/DSL/FileSystemDocInterpreter.hs +++ b/src/DSL/FileSystemDocInterpreter.hs @@ -15,7 +15,7 @@ import DSL.FileSystemEffect (FileSystem (..)) import Path.Extended (Path, toFilePath) import PyrethrumExtras (toS, txt, (?)) import Effectful.Dispatch.Dynamic (LocalEnv, interpret) -import DSL.DocInterpreterUtils (docErr, docErr2, docErr3, docErr4, docErrn') +import DSL.DocInterpreterUtils (docErr, docErr2, docErr3, docErr4) import DSL.Internal.NodeEvent (NodeEvent) -- TODO: implement docVal, docHush, docVoid, docVal', or docVoid' @@ -36,16 +36,12 @@ runFileSystem = -- todo: rename all variables / separate type signatures by using the other templateHaskell method WithCurrentDir _path _action -> docErr "withCurrentDir" "run action in current working directory" FindFilesWith _predicate searchDirs targetFileName -> - -- docErr4 - -- "findFilesWith" - -- "find all files that match the file name:" - -- (showPath targetFileName) - -- "and satisfy the given predicate in directories:" - -- (showPaths searchDirs) - docErrn' + docErr4 "findFilesWith" - ["find all files that match the file name:", showPath targetFileName, "and satisfy the given predicate in directories:", showPaths searchDirs] - [] + "find all files that match the file name:" + (showPath targetFileName) + "and satisfy the given predicate in directories:" + (showPaths searchDirs) FindFileWith _predicate searchDirs targetFileName -> docErr4 "findFileWith" diff --git a/src/DSL/OutEffect.hs b/src/DSL/OutEffect.hs index 91db8095..cc1fc698 100644 --- a/src/DSL/OutEffect.hs +++ b/src/DSL/OutEffect.hs @@ -4,8 +4,8 @@ module DSL.OutEffect where -import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>)) -import Effectful.Dispatch.Static (StaticRep, SideEffects(..), getStaticRep, unsafeEff_, evalStaticRep) +import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Static (StaticRep, SideEffects(..), getStaticRep, unsafeEff_) {- a very simple logging effect initially copied from diff --git a/src/DSL/OutInterpreter.hs b/src/DSL/OutInterpreter.hs index 812f1eeb..df38a652 100644 --- a/src/DSL/OutInterpreter.hs +++ b/src/DSL/OutInterpreter.hs @@ -7,8 +7,8 @@ module DSL.OutInterpreter ( ) where import DSL.OutEffect as OE -import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>)) -import Effectful.Dispatch.Static (StaticRep, SideEffects(..), getStaticRep, unsafeEff_, evalStaticRep) +import Effectful (Eff, IOE, (:>)) +import Effectful.Dispatch.Static (evalStaticRep) runOut :: (IOE :> es) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es b runOut = evalStaticRep . Out . Sink diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index cb2f192a..bf61877a 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -9,12 +9,10 @@ import CoreUtils qualified as C import DSL.Internal.NodeEvent qualified as NE import Data.Aeson.TH (defaultOptions, deriveJSON, deriveToJSON) import Data.Text as T (intercalate) -import Effectful.Concurrent.STM (TQueue) import Filter (FilterResult) import Internal.LoggingCore import PyrethrumExtras as PE (head, tail, (?)) import Prelude hiding (atomically, lines) -import UnliftIO (tryReadTQueue) type Log l a = BaseLog LogContext (Event l a) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index fa1c1311..968b816f 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -9,9 +9,10 @@ import Internal.LoggingCore qualified as L import Internal.SuiteFiltering (FilteredSuite (..)) import Internal.SuiteValidation (SuiteValidationError (..)) import Prepare qualified as P -import PyrethrumExtras (catchAll, txt, (?)) +import PyrethrumExtras (txt, (?)) import UnliftIO - ( finally, + ( tryAny, + finally, forConcurrently_, writeTMVar, ) @@ -29,7 +30,6 @@ import Prelude hiding (All, atomically, id, newEmptyTMVarIO, newTVarIO, readMVar {- todo :: define defect properties with sum type type and typeclass which returns defect info - -} newtype ThreadCount = ThreadCount {maxThreads :: Int} @@ -1108,14 +1108,16 @@ tryLock canLock hs cq lockedStatus = tryLockIO :: (s -> CanRun -> Bool) -> TVar s -> ChildQ a -> s -> IO Bool tryLockIO canLock hs cq lockedStatus = atomically $ tryLock canLock hs cq lockedStatus +-- debugging only +log :: (L.Event loc AE.NodeEvent -> c) -> Text -> c +log lgr = lgr . L.NodeEvent . AE.User . AE.Log + logRun :: Logger -> L.ExePath -> NodeType -> IO b -> IO (Either L.FailPoint b) logRun lgr path evt action = do lgr $ L.Start evt path finally - ( catchAll - -- TODO :: test for strictness issues esp with failing thread hook - -- eg returns handle and handle is closed - (Right <$> action) - (logReturnFailure lgr path evt) - ) + do + log lgr $ "!!!!!!!!!!!!!!!!!! RUNNING " <> txt evt <> " !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" + r <- tryAny action + r & either (logReturnFailure lgr path evt) (pure . Right) (lgr $ L.End evt path) diff --git a/src/Prepare.hs b/src/Prepare.hs index c1b57f06..7b3061d3 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -21,15 +21,16 @@ import DSL.Internal.NodeEvent DStateText (DStateText), FrameworkLog (Action, Check, CheckStart, Parse, SkipedCheckStart), ItemText (ItemText), - NodeEvent (Framework), + NodeEvent (Framework, User), Path, - exceptionEvent, LogSink, + exceptionEvent, LogSink, UserLog (Log), ) -import Data.Either.Extra (mapLeft) +import Data.Either.Extra (mapLeft) -- ToDO: move to Pyrelude import Internal.SuiteFiltering (FilteredSuite (..), filterSuite) import Internal.SuiteValidation (SuiteValidationError (..), chkSuite) import PyrethrumExtras (txt) import UnliftIO.Exception (tryAny) +import Data.Text.IO as IOT (putStrLn) -- TODO Full E2E property tests from Core fixtures and Hooks --> logs -- can reuse some suiteruntime chks @@ -180,6 +181,10 @@ prepSuiteElm interpreter rc suiteElm = flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () flog sink = sink . Framework +-- Debugging only +log :: (HasCallStack) => LogSink -> Text -> IO () +log sink = sink . User . Log + catchLog :: forall a. (HasCallStack) => LogSink -> IO a -> IO a catchLog as io = tryAny io >>= either (logThrow as) pure @@ -267,8 +272,14 @@ prepareTest interpreter rc path = do ds <- tryAny do + log snk "******************** Running action *****************" as <- runAction snk action i + log snk "******************** Action Run *****************" + log snk "******************** Logging AP State *****************" + -- TODO: special Mode for doc Don't log Ap State + IOT.putStrLn $ "Logging AP State " <> txt as flog snk . Parse path . ApStateText $ txt as + log snk "******************** AP State Logged *****************" unTry snk $ applyParser parser as applyChecks snk path i.checks ds From 44a5d43f06de5c66061317e4e6ea2b228ef6d125 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 10:48:17 +0000 Subject: [PATCH 07/43] Wip working --- examples/DocumenterDemo.hs | 2 +- src/Check.hs | 8 +++++--- src/CoreUtils.hs | 7 +++++-- src/DSL/Internal/NodeEvent.hs | 24 +++++++++++++++++------- src/DSL/OutInterpreter.hs | 7 +++++-- src/Filter.hs | 3 ++- src/Internal/Logging.hs | 18 ++++++++++-------- src/Internal/LoggingCore.hs | 35 ++++++++++++++++++++++++++++++----- src/Internal/SuiteRuntime.hs | 1 + src/Prepare.hs | 20 +++++++++++--------- 10 files changed, 87 insertions(+), 38 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 31fe2ba3..538730a7 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -152,7 +152,7 @@ data FSData = FSItem -} -data FSAS = FSAS +newtype FSAS = FSAS { paths :: [P.Path Abs File] } deriving (Show) diff --git a/src/Check.hs b/src/Check.hs index b012440c..7fe33107 100644 --- a/src/Check.hs +++ b/src/Check.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} module Check ( Check (..), @@ -91,7 +92,8 @@ instance ToJSON (Check v) where newtype Checks ds = Checks { un :: [Check ds] } - deriving (Show, Read, Semigroup, Monoid, IsList) + deriving (Show, Read) + deriving newtype (Semigroup, Monoid, IsList) mapRules :: (Check ds -> Check ds') -> Checks ds -> Checks ds' mapRules f = Checks . fmap f . coerce @@ -103,7 +105,7 @@ data CheckResult = Pass | Skip | Fail - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) data CheckReport = CheckReport @@ -116,7 +118,7 @@ data CheckReport , exception :: Text , callStack :: Text } - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) skipCheck :: Check ds -> CheckReport skipCheck (Check{header}) = CheckReport Skip header "Validation skipped" diff --git a/src/CoreUtils.hs b/src/CoreUtils.hs index 90bd016a..b53341cf 100644 --- a/src/CoreUtils.hs +++ b/src/CoreUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-} module CoreUtils where import UnliftIO.Concurrent qualified as C @@ -6,7 +7,7 @@ import Data.Aeson.TH (defaultOptions, deriveToJSON, deriveJSON) import PyrethrumExtras (txt) import Data.Text as T (lines) -data Hz = Once | Thread | Each deriving (Show, Eq, Ord) +data Hz = Once | Thread | Each deriving (Show, Eq, Ord, Generic, NFData) type ThreadId = Int @@ -14,7 +15,9 @@ type ThreadId = Int mkThreadId :: C.ThreadId -> ThreadId mkThreadId = read . drop 9 . show -newtype PException = MkException {displayText :: [Text]} deriving (Show, Eq, Ord) +newtype PException = MkException {displayText :: [Text]} + deriving (Show, Eq, Ord, Generic) + deriving newtype NFData exceptionTxt :: SomeException -> PException exceptionTxt = MkException . T.lines . txt . displayException diff --git a/src/DSL/Internal/NodeEvent.hs b/src/DSL/Internal/NodeEvent.hs index f71a5059..78292f7c 100644 --- a/src/DSL/Internal/NodeEvent.hs +++ b/src/DSL/Internal/NodeEvent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module DSL.Internal.NodeEvent where import Check (CheckReport) @@ -18,10 +19,16 @@ Framework FrameworkLog -> internal events from within a test or hook such as the data NodeEvent = User UserLog | Framework FrameworkLog - deriving stock (Show) + deriving (Show, Generic, NFData) -newtype ItemText = ItemText {text :: Text} deriving (Eq, Show, IsString) -newtype DStateText = DStateText {text :: Text} deriving (Eq, Show, IsString) + +newtype ItemText = ItemText {text :: Text} + deriving (Eq, Show) + deriving newtype (IsString, NFData) + +newtype DStateText = DStateText {text :: Text} + deriving (Eq, Show) + deriving newtype (IsString, NFData) -- framework logs that represent test fixtures have a path to that fixture -- Steps and Exceptions do not as they don't represent test fixture @@ -56,7 +63,7 @@ data FrameworkLog { exception :: Text , callStack :: Text } - deriving stock (Show) + deriving (Show, Generic, NFData) data UserLog = StartFolder Text @@ -76,7 +83,7 @@ data UserLog { message :: Text , details :: Text } - deriving stock (Eq, Show) + deriving (Eq, Show, Generic, NFData) data Path = NodePath @@ -87,10 +94,13 @@ data Path { id :: Int , title :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) + +newtype ApStateText = ApStateText {text :: Text} + deriving (Eq, Show) + deriving newtype (IsString, NFData) -newtype ApStateText = ApStateText {text :: Text} deriving (Eq, Show, IsString) $(deriveJSON defaultOptions ''ApStateText) diff --git a/src/DSL/OutInterpreter.hs b/src/DSL/OutInterpreter.hs index df38a652..cd977f84 100644 --- a/src/DSL/OutInterpreter.hs +++ b/src/DSL/OutInterpreter.hs @@ -10,5 +10,8 @@ import DSL.OutEffect as OE import Effectful (Eff, IOE, (:>)) import Effectful.Dispatch.Static (evalStaticRep) -runOut :: (IOE :> es) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es b -runOut = evalStaticRep . Out . Sink +runOut :: (IOE :> es, NFData a) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es b +runOut sink = + evalStaticRep . Out $ Sink forcedSink + where + forcedSink = sink . force diff --git a/src/Filter.hs b/src/Filter.hs index 99c4b688..bb4cd59a 100644 --- a/src/Filter.hs +++ b/src/Filter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module Filter ( Filter (..), FilterResult (..), @@ -22,7 +23,7 @@ data FilterResult t = MkFilterResult { target :: t, rejection :: Maybe Text } - deriving (Show, Eq, Functor) + deriving (Show, Eq, Functor, Generic, NFData) accepted :: FilterResult t -> Bool accepted = isNothing . (.rejection) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index bf61877a..b26a9ad4 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -26,16 +26,18 @@ data LogContext = MkLogContext { threadId :: C.ThreadId, idx :: Int } - deriving (Show) + deriving (Show, Generic, NFData) -data HookPos = Before | After | Setup | Teardown deriving (Show, Eq, Ord) +data HookPos = Before | After | Setup | Teardown deriving (Show, Eq, Ord, Generic, NFData) data NodeType = Hook Hz HookPos | Test - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) -newtype ExePath = ExePath {un :: [NE.Path]} deriving (Show, Eq, Ord) +newtype ExePath = ExePath {un :: [NE.Path]} + deriving (Show, Eq, Ord) + deriving newtype NFData topPath :: ExePath -> Maybe NE.Path topPath = PE.head . coerce @@ -120,16 +122,16 @@ data Event loc evnt { event :: evnt } | EndExecution - deriving (Show) + deriving (Show, Generic, NFData) -testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) +testLogControls :: forall l a. (Show a, Show l, NFData l, NFData a, NFData (Log l a)) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) testLogControls = testLogControls' expandEvent -- -- NodeEvent (a) a loggable event generated from within a node -- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors -- -- Log a - adds thread id and index to EngineEvent -expandEvent :: C.ThreadId -> Int -> Event l a -> Log l a -expandEvent threadId idx = MkLog (MkLogContext threadId idx) +expandEvent :: (NFData l, NFData a) => C.ThreadId -> Int -> Event l a -> Log l a +expandEvent threadId idx = force . mkLog (MkLogContext threadId idx) $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) diff --git a/src/Internal/LoggingCore.hs b/src/Internal/LoggingCore.hs index 9026fe61..4ccc8d14 100644 --- a/src/Internal/LoggingCore.hs +++ b/src/Internal/LoggingCore.hs @@ -1,11 +1,19 @@ -module Internal.LoggingCore where +{-# LANGUAGE DeriveAnyClass #-} +module Internal.LoggingCore ( + mkLog, + testLogControls', + BaseLog(..), + runWithLogger, + LogControls(..), + LoggerSource(..) +) where -- TODO: Explicit exports remove old code import BasePrelude qualified as P import CoreUtils qualified as C import Effectful.Concurrent.STM (TQueue) import Text.Show.Pretty (pPrint) -import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue ) +import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue, tryAny ) import UnliftIO.Concurrent (ThreadId) import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) import Prelude hiding (atomically, lines) @@ -16,6 +24,10 @@ data BaseLog lc evt = MkLog event :: evt } deriving (Show) + deriving (Generic, NFData) + +mkLog :: NFData evt => lc -> evt -> BaseLog lc evt +mkLog lc evt = MkLog lc $ force evt data LoggerSource l = MkLoggerSource { rootLogger :: l -> IO (), @@ -71,7 +83,7 @@ q2List qu = reverse <$> recurse [] qu tryReadTQueue q >>= maybe (pure l) (\e -> recurse (e : l) q) -testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) +testLogControls' :: forall l lx. (Show lx, NFData lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) testLogControls' aggregator wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -83,14 +95,27 @@ testLogControls' aggregator wantConsole = do >>= maybe (pure ()) (\evt -> when wantConsole (pPrint evt) >> logWorker) + -- (\evt -> when wantConsole (printToConsole evt) >> logWorker) + + printToConsole :: Show evt => evt -> IO () + printToConsole evt = do + ep <- tryAny (pPrint evt) + ep & either + (\e -> do + putStrLn "Error printing event:\n" + pPrint e + ) + pure stopWorker :: IO () stopWorker = atomically $ writeTChan chn Nothing sink :: lx -> IO () sink eventLog = + let ev = force eventLog + in atomically $ do - writeTChan chn $ Just eventLog - writeTQueue log eventLog + writeTChan chn $ Just ev + writeTQueue log ev pure (LogControls {..}, q2List log) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 968b816f..bea58bf9 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -1119,5 +1119,6 @@ logRun lgr path evt action = do do log lgr $ "!!!!!!!!!!!!!!!!!! RUNNING " <> txt evt <> " !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" r <- tryAny action + log lgr $ "!!!!!!!!!!!!!!!!!! FINISHED RUNNING ACTION " <> txt evt <> " !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" r & either (logReturnFailure lgr path evt) (pure . Right) (lgr $ L.End evt path) diff --git a/src/Prepare.hs b/src/Prepare.hs index 7b3061d3..3a6bf874 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -179,11 +179,11 @@ prepSuiteElm interpreter rc suiteElm = C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () -flog sink = sink . Framework +flog sink = sink . force . Framework -- Debugging only -log :: (HasCallStack) => LogSink -> Text -> IO () -log sink = sink . User . Log +dblog :: (HasCallStack) => LogSink -> Text -> IO () +dblog sink = sink . User . Log catchLog :: forall a. (HasCallStack) => LogSink -> IO a -> IO a catchLog as io = tryAny io >>= either (logThrow as) pure @@ -272,14 +272,16 @@ prepareTest interpreter rc path = do ds <- tryAny do - log snk "******************** Running action *****************" + dblog snk "******************** Running Action *****************" as <- runAction snk action i - log snk "******************** Action Run *****************" - log snk "******************** Logging AP State *****************" + dblog snk "******************** Action Run *****************" + dblog snk "******************** Logging AP State *****************" -- TODO: special Mode for doc Don't log Ap State - IOT.putStrLn $ "Logging AP State " <> txt as - flog snk . Parse path . ApStateText $ txt as - log snk "******************** AP State Logged *****************" + let !evt = force . Parse path . force ApStateText . force $ txt as + -- IOT.putStrLn $ "Logging AP State " <> txt as + flog snk $ force evt + + dblog snk "******************** AP State Logged *****************" unTry snk $ applyParser parser as applyChecks snk path i.checks ds From 572812792e61e3586aefbd0a7971b9070046aca0 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 11:07:44 +0000 Subject: [PATCH 08/43] clean up --- examples/DocumenterDemo.hs | 2 +- src/Internal/LoggingCore.hs | 19 +++---------------- src/Internal/SuiteRuntime.hs | 6 ------ src/Prepare.hs | 13 ++----------- 4 files changed, 6 insertions(+), 34 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 538730a7..c92c357c 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -100,7 +100,7 @@ OH THE HUMANITY !!! 1.3 - log outfull channel :: FIXED with use of proper interpreter 2. exception not handled - reinstate exception for doc :: DONE - - its the lazy logging !!! + - its the lazy logging !! 3. laziness not working - need special handling for docmode -} diff --git a/src/Internal/LoggingCore.hs b/src/Internal/LoggingCore.hs index 4ccc8d14..3eb858ba 100644 --- a/src/Internal/LoggingCore.hs +++ b/src/Internal/LoggingCore.hs @@ -83,7 +83,7 @@ q2List qu = reverse <$> recurse [] qu tryReadTQueue q >>= maybe (pure l) (\e -> recurse (e : l) q) -testLogControls' :: forall l lx. (Show lx, NFData lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) +testLogControls' :: forall l lx. Show lx => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) testLogControls' aggregator wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -95,27 +95,14 @@ testLogControls' aggregator wantConsole = do >>= maybe (pure ()) (\evt -> when wantConsole (pPrint evt) >> logWorker) - -- (\evt -> when wantConsole (printToConsole evt) >> logWorker) - - printToConsole :: Show evt => evt -> IO () - printToConsole evt = do - ep <- tryAny (pPrint evt) - ep & either - (\e -> do - putStrLn "Error printing event:\n" - pPrint e - ) - pure stopWorker :: IO () stopWorker = atomically $ writeTChan chn Nothing sink :: lx -> IO () sink eventLog = - let ev = force eventLog - in atomically $ do - writeTChan chn $ Just ev - writeTQueue log ev + writeTChan chn $ Just eventLog + writeTQueue log eventLog pure (LogControls {..}, q2List log) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index bea58bf9..3ef370f4 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -1108,17 +1108,11 @@ tryLock canLock hs cq lockedStatus = tryLockIO :: (s -> CanRun -> Bool) -> TVar s -> ChildQ a -> s -> IO Bool tryLockIO canLock hs cq lockedStatus = atomically $ tryLock canLock hs cq lockedStatus --- debugging only -log :: (L.Event loc AE.NodeEvent -> c) -> Text -> c -log lgr = lgr . L.NodeEvent . AE.User . AE.Log - logRun :: Logger -> L.ExePath -> NodeType -> IO b -> IO (Either L.FailPoint b) logRun lgr path evt action = do lgr $ L.Start evt path finally do - log lgr $ "!!!!!!!!!!!!!!!!!! RUNNING " <> txt evt <> " !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" r <- tryAny action - log lgr $ "!!!!!!!!!!!!!!!!!! FINISHED RUNNING ACTION " <> txt evt <> " !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" r & either (logReturnFailure lgr path evt) (pure . Right) (lgr $ L.End evt path) diff --git a/src/Prepare.hs b/src/Prepare.hs index 3a6bf874..d9916785 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -181,10 +181,6 @@ prepSuiteElm interpreter rc suiteElm = flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () flog sink = sink . force . Framework --- Debugging only -dblog :: (HasCallStack) => LogSink -> Text -> IO () -dblog sink = sink . User . Log - catchLog :: forall a. (HasCallStack) => LogSink -> IO a -> IO a catchLog as io = tryAny io >>= either (logThrow as) pure @@ -272,16 +268,11 @@ prepareTest interpreter rc path = do ds <- tryAny do - dblog snk "******************** Running Action *****************" as <- runAction snk action i - dblog snk "******************** Action Run *****************" - dblog snk "******************** Logging AP State *****************" -- TODO: special Mode for doc Don't log Ap State - let !evt = force . Parse path . force ApStateText . force $ txt as + let !evt = Parse path . ApStateText $ txt as -- IOT.putStrLn $ "Logging AP State " <> txt as - flog snk $ force evt - - dblog snk "******************** AP State Logged *****************" + flog snk evt unTry snk $ applyParser parser as applyChecks snk path i.checks ds From 7cf2770d8b3c7a982d7f3a7f3835aa81fc6560cd Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 11:12:46 +0000 Subject: [PATCH 09/43] warning clean up --- src/Internal/Logging.hs | 2 +- src/Internal/LoggingCore.hs | 2 +- src/Prepare.hs | 5 ++--- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index b26a9ad4..80246477 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -124,7 +124,7 @@ data Event loc evnt | EndExecution deriving (Show, Generic, NFData) -testLogControls :: forall l a. (Show a, Show l, NFData l, NFData a, NFData (Log l a)) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) +testLogControls :: forall l a. (Show a, Show l, NFData l, NFData a) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) testLogControls = testLogControls' expandEvent -- -- NodeEvent (a) a loggable event generated from within a node diff --git a/src/Internal/LoggingCore.hs b/src/Internal/LoggingCore.hs index 3eb858ba..e2945690 100644 --- a/src/Internal/LoggingCore.hs +++ b/src/Internal/LoggingCore.hs @@ -13,7 +13,7 @@ import BasePrelude qualified as P import CoreUtils qualified as C import Effectful.Concurrent.STM (TQueue) import Text.Show.Pretty (pPrint) -import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue, tryAny ) +import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue ) import UnliftIO.Concurrent (ThreadId) import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) import Prelude hiding (atomically, lines) diff --git a/src/Prepare.hs b/src/Prepare.hs index d9916785..f3477787 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -21,16 +21,15 @@ import DSL.Internal.NodeEvent DStateText (DStateText), FrameworkLog (Action, Check, CheckStart, Parse, SkipedCheckStart), ItemText (ItemText), - NodeEvent (Framework, User), + NodeEvent (Framework), Path, - exceptionEvent, LogSink, UserLog (Log), + exceptionEvent, LogSink, ) import Data.Either.Extra (mapLeft) -- ToDO: move to Pyrelude import Internal.SuiteFiltering (FilteredSuite (..), filterSuite) import Internal.SuiteValidation (SuiteValidationError (..), chkSuite) import PyrethrumExtras (txt) import UnliftIO.Exception (tryAny) -import Data.Text.IO as IOT (putStrLn) -- TODO Full E2E property tests from Core fixtures and Hooks --> logs -- can reuse some suiteruntime chks From dace11202b52ccd316ec6134c36102ebfd2c11b7 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 23:39:49 +0000 Subject: [PATCH 10/43] Consolidated logging modules --- examples/DocumenterDemo.hs | 15 +---- examples/PyrethrumBase.hs | 1 - pyrethrum.cabal | 4 +- src/Core.hs | 2 +- src/DSL/Internal/NodeEvent.hs | 17 ++++-- src/DSL/Logging.hs | 20 +++++++ src/DSL/OutInterpreter.hs | 4 +- src/Internal/Logging.hs | 110 ++++++++++++++++++++++++++++++++-- src/Internal/LoggingCore.hs | 108 --------------------------------- src/Internal/SuiteRuntime.hs | 1 - src/Prepare.hs | 2 +- test/SuiteRuntimeTestBase.hs | 2 +- 12 files changed, 149 insertions(+), 137 deletions(-) create mode 100644 src/DSL/Logging.hs delete mode 100644 src/Internal/LoggingCore.hs diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index c92c357c..39f4613c 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -16,6 +16,7 @@ import Filter (Filters (..)) import Internal.Logging qualified as L import Internal.SuiteRuntime (ThreadCount (..)) import Path as P (Path, reldir, toFilePath) +import DSL.Logging import PyrethrumBase ( SuiteRunner, Suite, @@ -56,12 +57,7 @@ docDemo = runDemo docRunner -- ############### Test Case ################### --- TODO: repeated code - refactor -logShow :: (HasLog es, Show a) => a -> Eff es () -logShow = out . User . Log . txt -log :: (HasLog es) => Text -> Eff es () -log = out . User . Log -- copied from FileSystemDocDemo.hs @@ -151,7 +147,6 @@ data FSData = FSItem deriving (Show, Read) -} - newtype FSAS = FSAS { paths :: [P.Path Abs File] } @@ -182,16 +177,13 @@ fsItems _rc = docWebDriverDemo :: IO () docWebDriverDemo = runDemo docRunner webDriverSuite --- $> docWebDriverDemo --- *** Exception: --- Exception thrown in step documentation. --- Value forced from function: 'driverStatus' in documentation mode. --- Use docVal, docHush, docVoid, docVal' to replace or silence this value from where the step is called: 'driverStatus' webDriverSuite :: Suite webDriverSuite = [Fixture (NodePath "WebDriverDemo" "test") test] +-- >>> docWebDriverDemo + test :: Fixture () test = Full config action parse items @@ -215,7 +207,6 @@ _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-c action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS action _rc i = do log $ "test title is: " <> i.title - error "BANG" status <- driver_status log $ "the driver status is (from root): " <> txt status ses <- newSession diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 101825de..ec0e16e0 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -33,7 +33,6 @@ import DSL.OutInterpreter ( runOut ) import Effectful (Eff, IOE, runEff, type (:>)) import Filter (Filters) import Internal.Logging qualified as L -import Internal.LoggingCore qualified as L import Internal.SuiteRuntime (ThreadCount, execute, executeWithoutValidation) import PyrethrumConfigTypes as CG ( Country (..), diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 608c5c9b..35bdfd3c 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: 3ef7573ce099bebdb3230f0e91740c75b087ab0958eb134b76b17d4ea94f4921 +-- hash: 78ba4888f189d6b16769757a2f3b3b7cb8ac96c8824b10c37d839689e5c9a95c name: pyrethrum version: 0.1.0.0 @@ -89,11 +89,11 @@ library DSL.Internal.FileSystemIO DSL.Internal.FileSystemPure DSL.Internal.NodeEvent + DSL.Logging DSL.OutEffect DSL.OutInterpreter Filter Internal.Logging - Internal.LoggingCore Internal.LogQueries Internal.SuiteFiltering Internal.SuiteRuntime diff --git a/src/Core.hs b/src/Core.hs index d1ab4e83..d38b1825 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -1,7 +1,7 @@ module Core where import Check (Checks) -import DSL.Internal.NodeEvent hiding (Check) +import DSL.Internal.NodeEvent ( LogSink, Path ) import Data.Aeson (ToJSON (..)) import GHC.Records (HasField) import CoreUtils (Hz (..)) diff --git a/src/DSL/Internal/NodeEvent.hs b/src/DSL/Internal/NodeEvent.hs index 78292f7c..875dc427 100644 --- a/src/DSL/Internal/NodeEvent.hs +++ b/src/DSL/Internal/NodeEvent.hs @@ -8,10 +8,19 @@ import PyrethrumExtras (toS) type LogSink = NodeEvent -> IO () -- TODO: Note plugin {- -NodeEvent is a data type that represents events emitted by or from WITHIN a node (ie. a Hook or a Fixture) -This is distinct from the EngineEvent data type which marks the BOUNDARIES of and events related to the nodes -themselves (such as the start and end of a Hook or skipping a Fixture) - +NodeEvent is a data type that represents specfic types of events loggged from WITHIN a node (ie. a Hook or a Fixture) +eg. + - starting a test action + - executing checks + - user logs + +This is distinct from the Events emited by the Suite Runtime that mark the boundaries of these actions +eg. + - start of test + - end of hook + - filter log + - end suite execution + User UserLog -> ad hoc logging implemented by users of the framework Framework FrameworkLog -> internal events from within a test or hook such as the start of a test phase such as action, parse and checks -} diff --git a/src/DSL/Logging.hs b/src/DSL/Logging.hs new file mode 100644 index 00000000..244d6166 --- /dev/null +++ b/src/DSL/Logging.hs @@ -0,0 +1,20 @@ +module DSL.Logging ( + log, + logTxt +) where + +import DSL.OutEffect +import DSL.Internal.NodeEvent qualified as E +import Effectful as EF + ( Eff, + type (:>), + ) +import PyrethrumExtras (txt) + +{- TODO Other efect funtions such as warning and folder -} + +logTxt :: (Out E.NodeEvent :> es, Show a) => a -> Eff es () +logTxt = log . txt + +log :: (Out E.NodeEvent :> es) => Text -> Eff es () +log = out . E.User . E.Log \ No newline at end of file diff --git a/src/DSL/OutInterpreter.hs b/src/DSL/OutInterpreter.hs index cd977f84..94ad90e0 100644 --- a/src/DSL/OutInterpreter.hs +++ b/src/DSL/OutInterpreter.hs @@ -14,4 +14,6 @@ runOut :: (IOE :> es, NFData a) => (a -> IO ()) -> Eff (Out a : es) b -> Eff es runOut sink = evalStaticRep . Out $ Sink forcedSink where - forcedSink = sink . force + forcedSink !a = sink a + + diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 80246477..a1eace28 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -10,10 +10,108 @@ import DSL.Internal.NodeEvent qualified as NE import Data.Aeson.TH (defaultOptions, deriveJSON, deriveToJSON) import Data.Text as T (intercalate) import Filter (FilterResult) -import Internal.LoggingCore import PyrethrumExtras as PE (head, tail, (?)) import Prelude hiding (atomically, lines) +-- TODO: Explicit exports remove old code +import BasePrelude qualified as P +import CoreUtils qualified as C +import Effectful.Concurrent.STM (TQueue) +import Text.Show.Pretty (pPrint) +import UnliftIO (concurrently_, finally, newIORef, tryReadTQueue) +import UnliftIO.Concurrent (ThreadId) +import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) +import Prelude hiding (atomically, lines) + + +{- Fully polymorphic base logging functions -} + +data BaseLog lc evt = MkLog + { logContext :: lc, + event :: evt + } + deriving (Show) + deriving (Generic, NFData) + +data LoggerSource l = MkLoggerSource + { rootLogger :: l -> IO (), + newLogger :: IO (l -> IO ()) + } + +runWithLogger :: forall l lx. LogControls l lx -> (LoggerSource l -> IO ()) -> IO () +runWithLogger + LogControls + { sink, + aggregator, + logWorker, + stopWorker + } + action = + do + rootLogger <- mkNewLogger + let loggerSource = MkLoggerSource rootLogger mkNewLogger + -- logWorker and execution run concurrently + -- logworker serialises the log events emitted by the execution + concurrently_ + logWorker + ( finally + (action loggerSource) + stopWorker + ) + where + mkNewLogger :: IO (l -> IO ()) + mkNewLogger = mkLogger aggregator sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId + +-- adds log index and thread id to loggable event and sends it to the sink +mkLogger :: forall l lxp. (C.ThreadId -> Int -> l -> lxp) -> (lxp -> IO ()) -> IORef Int -> ThreadId -> l -> IO () +mkLogger aggregator sink idxRef thrdId logEvnt = do + tc <- readIORef idxRef + let nxt = succ tc + finally (sink $ aggregator (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt + +-- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure + +data LogControls l lx = LogControls + { aggregator :: C.ThreadId -> Int -> l -> lx, + sink :: lx -> IO (), + logWorker :: IO (), + stopWorker :: IO () + } + +q2List :: TQueue a -> STM [a] +q2List qu = reverse <$> recurse [] qu + where + recurse :: [a] -> TQueue a -> STM [a] + recurse l q = + tryReadTQueue q + >>= maybe (pure l) (\e -> recurse (e : l) q) + +testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) +testLogControls' aggregator wantConsole = do + chn <- newTChanIO + log <- newTQueueIO + + -- https://stackoverflow.com/questions/32040536/haskell-forkio-threads-writing-on-top-of-each-other-with-putstrln + let logWorker :: IO () + logWorker = + atomically (readTChan chn) + >>= maybe + (pure ()) + (\evt -> when wantConsole (pPrint evt) >> logWorker) + + stopWorker :: IO () + stopWorker = atomically $ writeTChan chn Nothing + + sink :: lx -> IO () + sink eventLog = + atomically $ do + writeTChan chn $ Just eventLog + writeTQueue log eventLog + + pure (LogControls {..}, q2List log) + +{- Logging functions specialised to Event type -} + type Log l a = BaseLog LogContext (Event l a) ctx :: Log l a -> LogContext @@ -124,16 +222,18 @@ data Event loc evnt | EndExecution deriving (Show, Generic, NFData) -testLogControls :: forall l a. (Show a, Show l, NFData l, NFData a) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) +testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) testLogControls = testLogControls' expandEvent -- -- NodeEvent (a) a loggable event generated from within a node -- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors -- -- Log a - adds thread id and index to EngineEvent -expandEvent :: (NFData l, NFData a) => C.ThreadId -> Int -> Event l a -> Log l a -expandEvent threadId idx = force . mkLog (MkLogContext threadId idx) +expandEvent :: C.ThreadId -> Int -> Event l a -> Log l a +expandEvent threadId idx = MkLog (MkLogContext threadId idx) $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) $(deriveJSON defaultOptions ''NodeType) -$(deriveToJSON defaultOptions ''Event) \ No newline at end of file +$(deriveToJSON defaultOptions ''Event) + + diff --git a/src/Internal/LoggingCore.hs b/src/Internal/LoggingCore.hs deleted file mode 100644 index e2945690..00000000 --- a/src/Internal/LoggingCore.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -module Internal.LoggingCore ( - mkLog, - testLogControls', - BaseLog(..), - runWithLogger, - LogControls(..), - LoggerSource(..) -) where - --- TODO: Explicit exports remove old code -import BasePrelude qualified as P -import CoreUtils qualified as C -import Effectful.Concurrent.STM (TQueue) -import Text.Show.Pretty (pPrint) -import UnliftIO ( concurrently_, finally, newIORef, tryReadTQueue ) -import UnliftIO.Concurrent (ThreadId) -import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) -import Prelude hiding (atomically, lines) - - -data BaseLog lc evt = MkLog - { logContext :: lc, - event :: evt - } - deriving (Show) - deriving (Generic, NFData) - -mkLog :: NFData evt => lc -> evt -> BaseLog lc evt -mkLog lc evt = MkLog lc $ force evt - -data LoggerSource l = MkLoggerSource - { rootLogger :: l -> IO (), - newLogger :: IO (l -> IO ()) - } - -runWithLogger :: forall l lx. LogControls l lx -> (LoggerSource l -> IO ()) -> IO () -runWithLogger - LogControls - { sink, - aggregator, - logWorker, - stopWorker - } - action = - do - rootLogger <- mkNewLogger - let loggerSource = MkLoggerSource rootLogger mkNewLogger - -- logWorker and execution run concurrently - -- logworker serialises the log events emitted by the execution - concurrently_ - logWorker - ( finally - (action loggerSource) - stopWorker - ) - where - mkNewLogger :: IO (l -> IO ()) - mkNewLogger = mkLogger aggregator sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId - --- adds log index and thread id to loggable event and sends it to the sink -mkLogger :: forall l lxp. (C.ThreadId -> Int -> l -> lxp) -> (lxp -> IO ()) -> IORef Int -> ThreadId -> l -> IO () -mkLogger aggregator sink idxRef thrdId logEvnt = do - tc <- readIORef idxRef - let nxt = succ tc - finally (sink $ aggregator (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt - --- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure - -data LogControls l lx = LogControls - { aggregator :: C.ThreadId -> Int -> l -> lx, - sink :: lx -> IO (), - logWorker :: IO (), - stopWorker :: IO () - } - - -q2List :: TQueue a -> STM [a] -q2List qu = reverse <$> recurse [] qu - where - recurse :: [a] -> TQueue a -> STM [a] - recurse l q = - tryReadTQueue q - >>= maybe (pure l) (\e -> recurse (e : l) q) - -testLogControls' :: forall l lx. Show lx => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) -testLogControls' aggregator wantConsole = do - chn <- newTChanIO - log <- newTQueueIO - - -- https://stackoverflow.com/questions/32040536/haskell-forkio-threads-writing-on-top-of-each-other-with-putstrln - let logWorker :: IO () - logWorker = - atomically (readTChan chn) - >>= maybe - (pure ()) - (\evt -> when wantConsole (pPrint evt) >> logWorker) - - stopWorker :: IO () - stopWorker = atomically $ writeTChan chn Nothing - - sink :: lx -> IO () - sink eventLog = - atomically $ do - writeTChan chn $ Just eventLog - writeTQueue log eventLog - - pure (LogControls {..}, q2List log) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 3ef370f4..fa26cb43 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -5,7 +5,6 @@ import CoreUtils (Hz (..)) import DSL.Internal.NodeEvent qualified as AE import Internal.Logging (HookPos (..), NodeType (..)) import Internal.Logging qualified as L -import Internal.LoggingCore qualified as L import Internal.SuiteFiltering (FilteredSuite (..)) import Internal.SuiteValidation (SuiteValidationError (..)) import Prepare qualified as P diff --git a/src/Prepare.hs b/src/Prepare.hs index f3477787..e9fb879d 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -178,7 +178,7 @@ prepSuiteElm interpreter rc suiteElm = C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () -flog sink = sink . force . Framework +flog sink = sink . Framework catchLog :: forall a. (HasCallStack) => LogSink -> IO a -> IO a catchLog as io = tryAny io >>= either (logThrow as) pure diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index 14486161..4854667e 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -44,9 +44,9 @@ import Internal.Logging as L parentPath, testLogControls, topPath, + BaseLog (..), LogContext (..) ) -import Internal.LoggingCore (BaseLog (..)) import Internal.SuiteRuntime (ThreadCount (..), executeWithoutValidation) import Prepare qualified as P import PyrethrumExtras (ConvertString, onError, toS, txt, (?)) From b557772c694d0e500925f53c5c5c56157f792593 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 20 Sep 2024 23:42:03 +0000 Subject: [PATCH 11/43] added todos --- examples/DocumenterDemo.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 39f4613c..5dfcb456 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -182,6 +182,10 @@ webDriverSuite :: Suite webDriverSuite = [Fixture (NodePath "WebDriverDemo" "test") test] +-- todo experiment with hooks (laziness) +-- altrenative prenode for documantation +-- Doc log and doc mock to make work + -- >>> docWebDriverDemo test :: Fixture () From 70097b59c3b3bb0bb08c4114e46af22f39ca649d Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 21 Sep 2024 08:35:30 +0000 Subject: [PATCH 12/43] remove fake parameter from driver status --- examples/DocumenterDemo.hs | 2 +- examples/WebDriverDocInterpreter.hs | 2 +- examples/WebDriverEffect.hs | 3 +-- examples/WebDriverIOInterpreter.hs | 2 +- 4 files changed, 4 insertions(+), 5 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 5dfcb456..a5c9e0d6 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -196,7 +196,7 @@ config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus driver_status = do - status <- driverStatus "NA" + status <- driverStatus log "Forcing driver status" log $ "the driver status is (from driver status): " <> txt status pure status diff --git a/examples/WebDriverDocInterpreter.hs b/examples/WebDriverDocInterpreter.hs index 5199a986..99608268 100644 --- a/examples/WebDriverDocInterpreter.hs +++ b/examples/WebDriverDocInterpreter.hs @@ -33,7 +33,7 @@ runWebDriver = handler _env = \case -- driver - DriverStatus i -> docErr2 "driverStatus" "get driver status" $ txt i + DriverStatus -> docErr "driverStatus" "get driver status" -- session NewSession -> docErr "newSession" "create new driver session" KillSession _sessionRef -> docErr "killSession" "kill driver session" diff --git a/examples/WebDriverEffect.hs b/examples/WebDriverEffect.hs index fde57fb0..e41459fc 100644 --- a/examples/WebDriverEffect.hs +++ b/examples/WebDriverEffect.hs @@ -45,8 +45,7 @@ every element interaction -} data WebUI :: Effect where -- driver - DriverStatus :: Text -> WebUI m DriverStatus - -- DriverStatus :: WebUI m DriverStatus + DriverStatus :: WebUI m DriverStatus -- session NewSession :: WebUI m SessionRef KillSession :: SessionRef -> WebUI m () diff --git a/examples/WebDriverIOInterpreter.hs b/examples/WebDriverIOInterpreter.hs index cf73e985..cc804876 100644 --- a/examples/WebDriverIOInterpreter.hs +++ b/examples/WebDriverIOInterpreter.hs @@ -26,7 +26,7 @@ runWebDriver = interpret $ \_ -> EF.liftIO . \case -- driver - DriverStatus _i -> status + DriverStatus -> status -- session NewSession -> newDefaultFirefoxSession KillSession sessionRef -> deleteSession sessionRef From e5e2784cb3c28b5992ecfb9c525f2a2c36d3ad83 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 21 Sep 2024 22:13:42 +0000 Subject: [PATCH 13/43] restore session ref --- examples/DocumenterDemo.hs | 14 +++++++------- examples/WebDriverDemo.hs | 2 +- examples/WebDriverEffect.hs | 14 +++++++++++--- package.yaml | 6 +++++- 4 files changed, 24 insertions(+), 12 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index a5c9e0d6..ca4666c2 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -40,7 +40,7 @@ import WebDriverEffect readElem, clickElem, sleep, - killSession ) + killSession, dsNothing, maximiseWindow2 ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) @@ -195,11 +195,7 @@ config :: FixtureConfig config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus -driver_status = do - status <- driverStatus - log "Forcing driver status" - log $ "the driver status is (from driver status): " <> txt status - pure status +driver_status = driverStatus _theInternet :: Text _theInternet = "https://the-internet.herokuapp.com/" @@ -212,9 +208,13 @@ action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS action _rc i = do log $ "test title is: " <> i.title status <- driver_status - log $ "the driver status is (from root): " <> txt status + log "GOT DRIVER STATUS" + dsNothing status + -- log $ "the driver status is (from root): " <> txt status ses <- newSession + log "GOT SESSION" maximiseWindow ses + log "WINDOE MAXIMISED" go ses _theInternet link <- findElem ses _checkBoxesLinkCss checkButtonText <- readElem ses link diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index e00c76b6..99de699d 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -62,7 +62,7 @@ config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus driver_status = do - status <- driverStatus "NA" + status <- driverStatus log $ "the driver status is: " <> txt status pure status diff --git a/examples/WebDriverEffect.hs b/examples/WebDriverEffect.hs index e41459fc..77f46e90 100644 --- a/examples/WebDriverEffect.hs +++ b/examples/WebDriverEffect.hs @@ -1,16 +1,18 @@ module WebDriverEffect - ( SessionRef (..), + ( WebUI (..), WebDriver, -- driver driverStatus, + dsNothing, -- session newSession, killSession, -- window fullscreenWindow, maximiseWindow, + maximiseWindow2, minimiseWindow, -- navigate go, @@ -22,12 +24,12 @@ module WebDriverEffect ) where -import Effectful as EF ( Effect, DispatchOf, Dispatch(Dynamic) ) +import Effectful as EF ( Effect, DispatchOf, Dispatch(Dynamic), Eff ) import Effectful.Reader.Static as ERS import Effectful.TH (makeEffect) import Prelude hiding (second) -import WebDriverSpec (SessionRef(..), ElementRef, DriverStatus, Selector) +import WebDriverSpec (ElementRef, DriverStatus, Selector, SessionRef) -- Effect @@ -63,8 +65,14 @@ data WebUI :: Effect where -- TODO move this its more generic (eg. used in REST wait loops) Sleep :: Int -> WebUI m () +dsNothing :: DriverStatus -> Eff es () +dsNothing _ds = pure () + makeEffect ''WebUI + +maximiseWindow2 :: SessionRef -> Eff es () +maximiseWindow2 _ses = pure () -- todo add newtype later and don't export type constructor to make -- sleep wait typesafe diff --git a/package.yaml b/package.yaml index d334c17a..9bb85106 100644 --- a/package.yaml +++ b/package.yaml @@ -132,7 +132,11 @@ ghc-options: - -fmax-pmcheck-models=10000000 - -ferror-spans - -fprint-potential-instances - # - -dth-dec-file -- generate template haskell + # generate template haskell splices files + # - -ddump-splices + # - -dth-dec-file + # - -ddump-to-file + # - -j3 #number of cores used by ghc in compiling # threading related options only has an effect for exes From bdd0d8afd386a071f55ecd1514a58c794acc26c4 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 22 Sep 2024 06:06:20 +0000 Subject: [PATCH 14/43] WIP documentation demo --- examples/DocumenterDemo.hs | 16 +------- examples/WebDriverDocInterpreter.hs | 25 ++++++------ examples/WebDriverEffect.hs | 14 +------ src/DSL/DocInterpreterUtils.hs | 59 ++++++++++++++++++++++++++--- src/Prepare.hs | 2 - 5 files changed, 68 insertions(+), 48 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index ca4666c2..ebad8320 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -40,7 +40,7 @@ import WebDriverEffect readElem, clickElem, sleep, - killSession, dsNothing, maximiseWindow2 ) + killSession ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) @@ -88,19 +88,6 @@ fsDemoAp = do -- ################### 1. FS App with full runtime ################## -{- -OH THE HUMANITY !!! -1. log scrambling z:: FIXED - 1.1 - take unhandled excption out of the picture in demo - FAILED STILL SCRABLED - 1.2 - switch off filter log (execute -> executeWithoutValidation) - FAILED STILL SCRABLED - 1.3 - log outfull channel :: FIXED with use of proper interpreter -2. exception not handled - - reinstate exception for doc :: DONE - - its the lazy logging !! -3. laziness not working - - need special handling for docmode --} - fsSuiteDemo :: IO () fsSuiteDemo = docDemo fsSuite @@ -209,7 +196,6 @@ action _rc i = do log $ "test title is: " <> i.title status <- driver_status log "GOT DRIVER STATUS" - dsNothing status -- log $ "the driver status is (from root): " <> txt status ses <- newSession log "GOT SESSION" diff --git a/examples/WebDriverDocInterpreter.hs b/examples/WebDriverDocInterpreter.hs index 99608268..c2242b59 100644 --- a/examples/WebDriverDocInterpreter.hs +++ b/examples/WebDriverDocInterpreter.hs @@ -15,10 +15,11 @@ import Effectful.Dispatch.Dynamic ( interpret, LocalEnv, ) import WebDriverEffect (WebUI (..)) -import DSL.DocInterpreterUtils (docErr, docErr2) +import DSL.DocInterpreterUtils (docAction, docFake, docAction2, docFake2) import DSL.Internal.NodeEvent (NodeEvent) import DSL.OutEffect ( Out ) import PyrethrumExtras (txt) +import WebDriverSpec (ElementRef(..), DriverStatus (Ready), SessionRef (Session)) runWebDriver :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Eff (WebUI : es) a -> Eff es a runWebDriver = @@ -33,19 +34,19 @@ runWebDriver = handler _env = \case -- driver - DriverStatus -> docErr "driverStatus" "get driver status" + DriverStatus -> docFake Ready "get driver status" -- session - NewSession -> docErr "newSession" "create new driver session" - KillSession _sessionRef -> docErr "killSession" "kill driver session" + NewSession -> docFake (Session "new-session-id" )"create new driver session" + KillSession _sessionRef -> docAction "kill driver session" -- window - FullscreenWindow _sessionRef -> docErr "fullscreenWindow" "make browser fullscreen" - MaximiseWindow _sessionRef -> docErr "maximiseWindow" "maximise browser window" - MinimiseWindow _sessionRef -> docErr "minimiseWindow" "minimise browser window" + FullscreenWindow _sessionRef -> docAction "make browser fullscreen" + MaximiseWindow _sessionRef -> docAction "maximise browser window" + MinimiseWindow _sessionRef -> docAction"minimise browser window" -- navigate - Go _sessionRef url -> docErr2 "go" "navigate to:" url + Go _sessionRef url -> docAction2 "navigate to:" url -- page - FindElem _sessionRef selector -> docErr2 "findElem" "find element:" $ txt selector - ClickElem _sessionRef _elemRef -> docErr "clickElem" "click element (by element reference)" - ReadElem _sessionRef _elemRef -> docErr "readElem" "get element text (by element reference)" + FindElem _sessionRef selector -> docFake2 Element {id = "Fake Element Id"} "find element:" $ txt selector + ClickElem _sessionRef _elemRef -> docAction "click element (by element reference)" + ReadElem _sessionRef _elemRef -> docFake "Fake Element Text" "get element text (by element reference)" -- TODO move this its more generic (eg. used in REST wait loops) - Sleep milliSec -> docErr2 "go" "navigate to:" $ txt milliSec + Sleep milliSec -> docAction2 "sleep for:" $ txt milliSec diff --git a/examples/WebDriverEffect.hs b/examples/WebDriverEffect.hs index 77f46e90..7a6d3aa0 100644 --- a/examples/WebDriverEffect.hs +++ b/examples/WebDriverEffect.hs @@ -5,14 +5,12 @@ module WebDriverEffect WebDriver, -- driver driverStatus, - dsNothing, -- session newSession, killSession, -- window fullscreenWindow, maximiseWindow, - maximiseWindow2, minimiseWindow, -- navigate go, @@ -65,14 +63,4 @@ data WebUI :: Effect where -- TODO move this its more generic (eg. used in REST wait loops) Sleep :: Int -> WebUI m () -dsNothing :: DriverStatus -> Eff es () -dsNothing _ds = pure () - -makeEffect ''WebUI - - -maximiseWindow2 :: SessionRef -> Eff es () -maximiseWindow2 _ses = pure () --- todo add newtype later and don't export type constructor to make --- sleep wait typesafe - +makeEffect ''WebUI \ No newline at end of file diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index 04c775dd..2d9bd2b2 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -6,6 +6,17 @@ module DSL.DocInterpreterUtils docErr3, docErr4, docErrn, + docFake, + docFake2, + docFake3, + docFake4, + docFaken, + docAction, + docAction2, + docAction3, + docAction4, + docActionn, + DocException(..) ) where @@ -17,15 +28,16 @@ import Effectful as EF IOE, type (:>), ) +-- import BasePrelude (throw) + -{- data DocException = DocException Text | DocException' Text SomeException deriving (Show) instance Exception DocException - +{- adaptException :: forall es a. (HasCallStack, IOE :> es{- , E.Error DocException :> es -}) => IO a -> Eff es a adaptException m = EF.liftIO m `catch` \(e :: SomeException) -> E.throwError . DocException' "Exception thrown in documenter" $ e -} @@ -50,10 +62,9 @@ docErrn funcName dscFrags = do let funcDesc = T.intercalate " " dscFrags logStep funcDesc - -- TODO :: replace this later when have code to process call - -- stack right now out of the box call handling looks better - -- E.throwError . DocException $ - -- pure $ error "" + -- TODO :: Swith to custom DocException exception but must return full callstack + -- doesn't do it now but might fix itself with GHC 9.10.00 ~ otherwise need to investigate + -- pure . throw . DocException $ pure . error $ "\nException thrown in step documentation." <> "\n Value forced from function: '" @@ -75,3 +86,39 @@ docErr3 funcName funcDesc1 funcDesc2 funcDesc3 = docErrn funcName [funcDesc1, fu docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Text -> Eff es a docErr4 funcName funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3, funcDesc4] + + +docActionn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => [Text] -> Eff es () +docActionn dscFrags = logStep $ T.intercalate " " dscFrags + +docAction :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Eff es () +docAction funcDesc = docActionn [funcDesc] + +docAction2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Eff es () +docAction2 funcDesc1 funcDesc2 = docActionn [funcDesc1, funcDesc2] + +docAction3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Text -> Eff es () +docAction3 funcDesc1 funcDesc2 funcDesc3 = docActionn [funcDesc1, funcDesc2, funcDesc3] + +docAction4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Text -> Text -> Eff es () +docAction4 funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docActionn [funcDesc1, funcDesc2, funcDesc3, funcDesc4] + +docFaken :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> [Text] -> Eff es a +docFaken a dscFrags = + do + logStep $ T.intercalate " " dscFrags + pure a + + +docFake :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Eff es a +docFake a funcDesc = docFaken a [funcDesc] + +docFake2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Text -> Eff es a +docFake2 a funcDesc1 funcDesc2 = docFaken a [funcDesc1, funcDesc2] + +docFake3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Text -> Text -> Eff es a +docFake3 a funcDesc1 funcDesc2 funcDesc3 = docFaken a [funcDesc1, funcDesc2, funcDesc3] + +docFake4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text ->Text -> Text -> Text -> Eff es a +docFake4 a funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docFaken a [funcDesc1, funcDesc2, funcDesc3, funcDesc4] + diff --git a/src/Prepare.hs b/src/Prepare.hs index e9fb879d..257e4be4 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -268,9 +268,7 @@ prepareTest interpreter rc path = ds <- tryAny do as <- runAction snk action i - -- TODO: special Mode for doc Don't log Ap State let !evt = Parse path . ApStateText $ txt as - -- IOT.putStrLn $ "Logging AP State " <> txt as flog snk evt unTry snk $ applyParser parser as applyChecks snk path i.checks ds From eb26b5a70976ff746c21653fcce2245365340ab9 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 22 Sep 2024 07:36:12 +0000 Subject: [PATCH 15/43] bit of clean up --- src/DSL/DocInterpreterUtils.hs | 80 +++++++++++++++++----------------- 1 file changed, 39 insertions(+), 41 deletions(-) diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index 2d9bd2b2..67838e49 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -16,7 +16,7 @@ module DSL.DocInterpreterUtils docAction3, docAction4, docActionn, - DocException(..) + DocException (..), ) where @@ -28,8 +28,8 @@ import Effectful as EF IOE, type (:>), ) --- import BasePrelude (throw) +-- import BasePrelude (throw) data DocException = DocException Text @@ -37,6 +37,7 @@ data DocException deriving (Show) instance Exception DocException + {- adaptException :: forall es a. (HasCallStack, IOE :> es{- , E.Error DocException :> es -}) => IO a -> Eff es a adaptException m = EF.liftIO m `catch` \(e :: SomeException) -> E.throwError . DocException' "Exception thrown in documenter" $ e @@ -57,68 +58,65 @@ adaptException m = EF.liftIO m `catch` \(e :: SomeException) -> E.throwError . D logStep :: (Out NodeEvent :> es) => Text -> Eff es () logStep = out . Framework . Step -docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> [Text] -> Eff es a +logDesc :: (HasCallStack, Out NodeEvent :> es) => [Text] -> Eff es () +logDesc = logStep . T.intercalate " " + +docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> [Text] -> Eff es a docErrn funcName dscFrags = - do - let funcDesc = T.intercalate " " dscFrags - logStep funcDesc - -- TODO :: Swith to custom DocException exception but must return full callstack - -- doesn't do it now but might fix itself with GHC 9.10.00 ~ otherwise need to investigate - -- pure . throw . DocException $ - pure . error $ - "\nException thrown in step documentation." - <> "\n Value forced from function: '" - <> funcName - <> "' in documentation mode." - <> "\n Use docVal, docHush, docVoid, docVal'" - <> " to replace or silence this value from where the step is called: '" - <> funcName - <> "'" - -docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Eff es a + logDesc dscFrags + >> ( pure . error $ + "\nException thrown in step documentation." + <> "\n Value forced from function: '" + <> funcName + <> "' in documentation mode." + <> "\n Use docVal, docHush, docVoid, docVal'" + <> " to replace or silence this value from where the step is called: '" + <> funcName + <> "'" + ) + +-- TODO :: Swith to custom DocException exception but must return full callstack +-- doesn't do it now but might fix itself with GHC 9.10.00 ~ otherwise need to investigate +-- pure . throw . DocException $ + +docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Eff es a docErr funcName funcDesc = docErrn funcName [funcDesc] -docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Eff es a +docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Eff es a docErr2 funcName funcDesc1 funcDesc2 = docErrn funcName [funcDesc1, funcDesc2] -docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Eff es a +docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Eff es a docErr3 funcName funcDesc1 funcDesc2 funcDesc3 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3] -docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Error DocException :> es -}) => Text -> Text -> Text -> Text -> Text -> Eff es a +docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Text -> Eff es a docErr4 funcName funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3, funcDesc4] +docActionn :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => [Text] -> Eff es () +docActionn dscFrags = logStep $ T.intercalate " " dscFrags -docActionn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => [Text] -> Eff es () -docActionn dscFrags = logStep $ T.intercalate " " dscFrags - -docAction :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Eff es () +docAction :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Eff es () docAction funcDesc = docActionn [funcDesc] -docAction2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Eff es () +docAction2 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Eff es () docAction2 funcDesc1 funcDesc2 = docActionn [funcDesc1, funcDesc2] -docAction3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Text -> Eff es () +docAction3 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Eff es () docAction3 funcDesc1 funcDesc2 funcDesc3 = docActionn [funcDesc1, funcDesc2, funcDesc3] -docAction4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => Text -> Text -> Text -> Text -> Eff es () +docAction4 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Eff es () docAction4 funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docActionn [funcDesc1, funcDesc2, funcDesc3, funcDesc4] -docFaken :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> [Text] -> Eff es a -docFaken a dscFrags = - do - logStep $ T.intercalate " " dscFrags - pure a - +docFaken :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> [Text] -> Eff es a +docFaken a dscFrags = logDesc dscFrags >> pure a -docFake :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Eff es a +docFake :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Eff es a docFake a funcDesc = docFaken a [funcDesc] -docFake2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Text -> Eff es a +docFake2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Eff es a docFake2 a funcDesc1 funcDesc2 = docFaken a [funcDesc1, funcDesc2] -docFake3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text -> Text -> Text -> Eff es a +docFake3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Text -> Eff es a docFake3 a funcDesc1 funcDesc2 funcDesc3 = docFaken a [funcDesc1, funcDesc2, funcDesc3] -docFake4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es {- , E.Fakeor DocException :> es -}) => a -> Text ->Text -> Text -> Text -> Eff es a +docFake4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Text -> Text -> Eff es a docFake4 a funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docFaken a [funcDesc1, funcDesc2, funcDesc3, funcDesc4] - From 36ab972333a9aa23b934b2d5ab6fd11aa3a09ed5 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 22 Sep 2024 07:38:51 +0000 Subject: [PATCH 16/43] more clean ups --- examples/DocumenterDemo.hs | 9 ++++----- examples/WebDriverEffect.hs | 2 +- src/Internal/Logging.hs | 1 - 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index ebad8320..2fb578c4 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -5,8 +5,8 @@ module DocumenterDemo where import Check import Core (ParseException) import DSL.FileSystemEffect -import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) -import DSL.OutEffect (Out, out) +import DSL.Internal.NodeEvent (NodeEvent , Path (NodePath)) +import DSL.OutEffect (Out) import Data.Text (isInfixOf) import Effectful as EF ( Eff, @@ -22,14 +22,13 @@ import PyrethrumBase Suite, RunConfig, FixtureConfig(FxCfg), - HasLog, Fixture(Full), Node(Fixture), DataSource(ItemList), Depth(DeepRegression), defaultRunConfig, docRunner ) -import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) +import PyrethrumExtras (Abs, File, relfile, toS, (?)) import WebDriverEffect ( WebUI, driverStatus, @@ -181,7 +180,7 @@ test = Full config action parse items config :: FixtureConfig config = FxCfg "test" DeepRegression -driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus +driver_status :: (WebUI :> es) => Eff es DriverStatus driver_status = driverStatus _theInternet :: Text diff --git a/examples/WebDriverEffect.hs b/examples/WebDriverEffect.hs index 7a6d3aa0..6475f237 100644 --- a/examples/WebDriverEffect.hs +++ b/examples/WebDriverEffect.hs @@ -22,7 +22,7 @@ module WebDriverEffect ) where -import Effectful as EF ( Effect, DispatchOf, Dispatch(Dynamic), Eff ) +import Effectful as EF ( Effect, DispatchOf, Dispatch(Dynamic)) import Effectful.Reader.Static as ERS import Effectful.TH (makeEffect) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index a1eace28..10faa916 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -15,7 +15,6 @@ import Prelude hiding (atomically, lines) -- TODO: Explicit exports remove old code import BasePrelude qualified as P -import CoreUtils qualified as C import Effectful.Concurrent.STM (TQueue) import Text.Show.Pretty (pPrint) import UnliftIO (concurrently_, finally, newIORef, tryReadTQueue) From b1c4045574c5a3764b1022046e5bbbdf8b8fe176 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 22 Sep 2024 22:08:41 +0000 Subject: [PATCH 17/43] WIP --- examples/PyrethrumBase.hs | 2 + src/Check.hs | 130 +++++++++++++++++++++----------------- src/Core.hs | 15 ++++- src/Prepare.hs | 98 ++++++++++++++++++---------- 4 files changed, 148 insertions(+), 97 deletions(-) diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index ec0e16e0..dd3cf9b6 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -93,6 +93,7 @@ docRunner suite filters runConfig threadCount logControls = prepared :: Either SuiteValidationError (FilteredSuite (PreNode IO ())) prepared = prepare $ C.MkSuiteExeParams { interpreter = docInterpreter, + mode = C.Listing {includeSteps = True, includeChecks = True}, suite = mkCoreSuite suite, filters, runConfig @@ -105,6 +106,7 @@ ioRunner suite filters runConfig threadCount logControls = execute threadCount logControls $ C.MkSuiteExeParams { interpreter = ioInterpreter, + mode = C.Run, suite = mkCoreSuite suite, filters, runConfig diff --git a/src/Check.hs b/src/Check.hs index 7fe33107..29098d1e 100644 --- a/src/Check.hs +++ b/src/Check.hs @@ -1,37 +1,38 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} -module Check ( - Check (..), - FailStatus (..), - Checks (..), - CheckResult (..), - CheckReport (..), - chk, - chk', - assert, - assert', - applyCheck, - skipChecks, - skipCheck, - mapRules, - filterRules, - -- TODO - more checks chkFalse', ChkEmpty, chkNotEmpty, chkEqual, chkNotEqual, chkContains, - -- chkNotContains, chkMatches, chkNotMatches, chkLessThan, chkLessThanOrEqual, chkGreaterThan, chkGreaterThanOrEqual -) +module Check + ( Check (..), + FailStatus (..), + Checks (..), + CheckResult (..), + CheckReport (..), + chk, + chk', + assert, + assert', + applyCheck, + filterRules, + listChecks, + mapRules, + skipChecks, + skipCheck, + -- TODO - more checks chkFalse', ChkEmpty, chkNotEmpty, chkEqual, chkNotEqual, chkContains, tagged variants + -- chkNotContains, chkMatches, chkNotMatches, chkLessThan, chkLessThanOrEqual, chkGreaterThan, chkGreaterThanOrEqual + ) where +-- import Prelude (Show (..), Read(..)) + +import BasePrelude (read) import Data.Aeson.TH (defaultOptions, deriveJSON, deriveToJSON) import Data.Aeson.Types as AT (ToJSON (toJSON), Value (String)) +import GHC.Read (Read (..)) +import GHC.Show (Show (..)) import PyrethrumExtras (toS, (?)) import UnliftIO (MonadUnliftIO, tryAny) import Prelude as P --- import Prelude (Show (..), Read(..)) -import GHC.Show (Show (..)) -import GHC.Read (Read(..)) -import BasePrelude (read) - -- import Hedgehog.Internal.Prelude (Show (..), Read(..)) data FailStatus = NonTerminal | Terminal deriving (Show, Read, Eq) @@ -39,51 +40,53 @@ data FailStatus = NonTerminal | Terminal deriving (Show, Read, Eq) $(deriveToJSON defaultOptions ''FailStatus) data Check ds = Check - { -- terminationStatus: + { -- failStatus: -- NonTerminal for regular checks (suceeding checks will be run) -- Terminal for asserts (suceeding checks will not be run) - failStatus :: FailStatus - , message :: Maybe (ds -> Text) - , header :: Text - , rule :: ds -> Bool + header :: Text, + message :: Maybe (ds -> Text), + failStatus :: FailStatus, + rule :: ds -> Bool } data CheckReadable = CheckLog - { header :: Text - , failStatus :: FailStatus + { header :: Text, + failStatus :: FailStatus } deriving (Show, Read) +singleton :: Text -> Maybe (ds -> Text) -> FailStatus -> (ds -> Bool) -> Checks ds +singleton hdr msg fs rule = Checks [Check hdr msg fs rule] + chk :: Text -> (ds -> Bool) -> Checks ds -chk header rule = Checks [Check NonTerminal Nothing header rule] +chk header = singleton header Nothing NonTerminal chk' :: Text -> (ds -> Text) -> (ds -> Bool) -> Checks ds -chk' header message rule = Checks [Check NonTerminal (Just message) header rule] +chk' header message = singleton header (Just message) NonTerminal assert :: Text -> (ds -> Bool) -> Checks ds -assert header rule = Checks [Check Terminal Nothing header rule] +assert header = singleton header Nothing Terminal -- todo: play with labelling values to see if useful similar to falsify: https://well-typed.com/blog/2023/04/falsify/?utm_source=pocket_reader#predicates assert' :: Text -> (ds -> Text) -> (ds -> Bool) -> Checks ds -assert' header message rule = Checks [Check Terminal (Just message) header rule] - +assert' header message = singleton header (Just message) Terminal instance Show (Check v) where show :: Check v -> String - show Check{header, failStatus} = P.show $ CheckLog header failStatus + show Check {header, failStatus} = P.show $ CheckLog header failStatus instance Read (Check v) where readsPrec :: Int -> String -> [(Check v, String)] readsPrec _ s = [(check, s)] - where - check = - Check - { failStatus = showable.failStatus - , message = Nothing - , header = showable.header - , rule = const . error $ "Tried to call rule on a deserialised version of Check for: " <> toS showable.header - } - showable = read @CheckReadable s + where + check = + Check + { failStatus = showable.failStatus, + message = Nothing, + header = showable.header, + rule = const . error $ "Tried to call rule on a deserialised version of Check for: " <> toS showable.header + } + showable = read @CheckReadable s instance ToJSON (Check v) where toJSON :: Check v -> Value @@ -109,23 +112,32 @@ data CheckResult data CheckReport = CheckReport - { result :: CheckResult - , message :: Text - , info :: Text + { header :: Text, + message :: Text, + result :: CheckResult } | CheckApplicationFailed + { header :: Text, + exception :: Text, + callStack :: Text + } + | CheckListing { header :: Text - , exception :: Text - , callStack :: Text } deriving (Show, Eq, Generic, NFData) skipCheck :: Check ds -> CheckReport -skipCheck (Check{header}) = CheckReport Skip header "Validation skipped" +skipCheck (Check {header}) = CheckReport header "Validation skipped" Skip skipChecks :: Checks ds -> [CheckReport] skipChecks chks = skipCheck <$> chks.un +listChecks :: Checks ds -> [CheckReport] +listChecks chks = listCheck <$> chks.un + where + listCheck :: Check ds -> CheckReport + listCheck (Check {header}) = CheckListing header + -- need to do this in an error handling context so we can catch and report -- exceptions thrown applying the check applyCheck :: (MonadUnliftIO m) => ds -> FailStatus -> Check ds -> m (CheckReport, FailStatus) @@ -147,16 +159,16 @@ applyCheck ds failStatus ck = ( \e -> pure ( CheckApplicationFailed - { header = ck.header - , exception = toS $ displayException e - , callStack = toS $ prettyCallStack callStack - } - , NonTerminal + { header = ck.header, + exception = toS $ displayException e, + callStack = toS $ prettyCallStack callStack + }, + NonTerminal ) ) pure - where - report rslt = CheckReport rslt ck.header (ck.message & maybe "" (ds &)) + where + report = CheckReport ck.header (ck.message & maybe "" (ds &)) $(deriveJSON defaultOptions ''CheckResult) $(deriveJSON defaultOptions ''CheckReport) diff --git a/src/Core.hs b/src/Core.hs index d38b1825..052b9015 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -1,11 +1,11 @@ module Core where import Check (Checks) -import DSL.Internal.NodeEvent ( LogSink, Path ) -import Data.Aeson (ToJSON (..)) -import GHC.Records (HasField) import CoreUtils (Hz (..)) +import DSL.Internal.NodeEvent (LogSink, Path) +import Data.Aeson (ToJSON (..)) import Filter (Filters) +import GHC.Records (HasField) data Before @@ -198,9 +198,18 @@ data Node m rc fc hi where fixture :: Fixture m rc fc hi } -> Node m rc fc hi + +data Mode + = Run + | Listing + { includeSteps :: Bool, + includeChecks :: Bool + } + data SuiteExeParams m rc fc where MkSuiteExeParams :: { suite :: [Node m rc fc ()], + mode :: Mode, filters :: Filters rc fc, interpreter :: forall a. LogSink -> m a -> IO a, runConfig :: rc diff --git a/src/Prepare.hs b/src/Prepare.hs index 257e4be4..3f2499a6 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -9,11 +9,11 @@ module Prepare ) where -import Check (Check, Checks (..), FailStatus (NonTerminal), applyCheck, skipChecks) +import Check (Check, Checks (..), FailStatus (NonTerminal), applyCheck, skipChecks, listChecks, CheckReport) import Control.Exception (throwIO) import Control.Exception.Extra (throw) import Control.Monad.Extra (foldM_) -import Core (SuiteExeParams) +import Core (Mode (..), SuiteExeParams) import Core qualified as C import CoreUtils (Hz) import DSL.Internal.NodeEvent @@ -21,14 +21,15 @@ import DSL.Internal.NodeEvent DStateText (DStateText), FrameworkLog (Action, Check, CheckStart, Parse, SkipedCheckStart), ItemText (ItemText), + LogSink, NodeEvent (Framework), Path, - exceptionEvent, LogSink, + exceptionEvent, ) -import Data.Either.Extra (mapLeft) -- ToDO: move to Pyrelude +import Data.Either.Extra (mapLeft) -- ToDO: move to Pyrelude import Internal.SuiteFiltering (FilteredSuite (..), filterSuite) import Internal.SuiteValidation (SuiteValidationError (..), chkSuite) -import PyrethrumExtras (txt) +import PyrethrumExtras (txt, uu) import UnliftIO.Exception (tryAny) -- TODO Full E2E property tests from Core fixtures and Hooks --> logs @@ -36,12 +37,12 @@ import UnliftIO.Exception (tryAny) -- should be able to write a converter from template to core hooks and fixtures prepare :: (C.Config rc, C.Config fc, HasCallStack) => SuiteExeParams m rc fc -> Either SuiteValidationError (FilteredSuite (PreNode IO ())) -prepare C.MkSuiteExeParams {suite, filters, interpreter, runConfig = rc} = +prepare C.MkSuiteExeParams {suite, mode, filters, interpreter, runConfig = rc} = mSuiteError & maybe ( Right $ MkFilteredSuite - { suite = prepSuiteElm interpreter rc <$> filtered.suite, + { suite = prepSuite mode interpreter rc filtered.suite, filterResults = filtered.filterResults } ) @@ -50,6 +51,9 @@ prepare C.MkSuiteExeParams {suite, filters, interpreter, runConfig = rc} = filtered = filterSuite filters rc suite mSuiteError = chkSuite filtered.filterResults +prepSuite :: (C.Config rc, C.Config fc, HasCallStack) => Mode -> (forall a. LogSink -> m a -> IO a) -> rc -> [C.Node m rc fc ()] -> [PreNode IO ()] +prepSuite mode interpreter rc suite = prepNode mode interpreter rc <$> suite + data PreNode m hi where Before :: { path :: Path, @@ -104,12 +108,15 @@ data Test m hi = MkTest action :: LogSink -> hi -> m () } -prepSuiteElm :: forall m rc fc hi. (HasCallStack, C.Config rc, C.Config fc) => - (forall a. LogSink -> m a -> IO a ) -- interpreter - -> rc -- runConfig - -> C.Node m rc fc hi -- node - -> PreNode IO hi -prepSuiteElm interpreter rc suiteElm = +prepNode :: + forall m rc fc hi. + (HasCallStack, C.Config rc, C.Config fc) => + Mode -> + (forall a. LogSink -> m a -> IO a) -> -- interpreter + rc -> -- runConfig + C.Node m rc fc hi -> -- node + PreNode IO hi +prepNode mode interpreter rc suiteElm = suiteElm & \case C.Hook {hook, path, subNodes = subNodes'} -> hook & \case @@ -117,7 +124,6 @@ prepSuiteElm interpreter rc suiteElm = Before { path, frequency, - -- !!! HERE NEED TO WORK OUT HOW SINK IS TREADED TROUGH AND MAKE SURE INTEPRETOR USES IT action = \snk -> const . intprt snk $ action rc, subNodes } @@ -171,11 +177,11 @@ prepSuiteElm interpreter rc suiteElm = subNodes = run <$> subNodes' run :: forall a. C.Node m rc fc a -> PreNode IO a - run = prepSuiteElm interpreter rc + run = prepNode mode interpreter rc intprt :: forall a. LogSink -> m a -> IO a intprt snk a = catchLog snk $ interpreter snk a - C.Fixture {path, fixture} -> prepareTest interpreter rc path fixture + C.Fixture {path, fixture} -> prepareTest mode interpreter rc path fixture flog :: (HasCallStack) => LogSink -> FrameworkLog -> IO () flog sink = sink . Framework @@ -189,12 +195,16 @@ logThrow sink ex = sink (exceptionEvent ex callStack) >> throwIO ex unTry :: forall a. LogSink -> Either SomeException a -> IO a unTry es = either (logThrow es) pure - -prepareTest :: forall m rc fc hi. (C.Config fc) => - (forall a. LogSink -> m a -> IO a ) -- interpreter - -> rc -- runConfig - -> Path -> C.Fixture m rc fc hi -> PreNode IO hi -prepareTest interpreter rc path = +prepareTest :: + forall m rc fc hi. + (C.Config fc) => + Mode -> -- meta interpreter mode + (forall a. LogSink -> m a -> IO a) -> -- interpreter + rc -> -- runConfig + Path -> -- path of test + C.Fixture m rc fc hi -> + PreNode IO hi +prepareTest mode interpreter rc path = \case C.Full {config, action, parse, items} -> Fixture @@ -256,29 +266,46 @@ prepareTest interpreter rc path = applyParser :: forall as ds. ((HasCallStack) => as -> Either C.ParseException ds) -> as -> Either SomeException ds applyParser parser as = mapLeft toException $ parser as + logItem :: forall i. (Show i) => LogSink -> i -> IO () + logItem snk = flog snk . Action path . ItemText . txt + runAction :: forall i as ds. (C.Item i ds) => LogSink -> (i -> m as) -> i -> IO as - runAction snk action i = - do - flog snk . Action path . ItemText $ txt i - catchLog snk . interpreter snk $ action i + runAction snk action = catchLog snk . interpreter snk . action runTest :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> ((HasCallStack) => as -> Either C.ParseException ds) -> i -> LogSink -> IO () runTest action parser i snk = - do - ds <- tryAny + case mode of + Run -> do - as <- runAction snk action i - let !evt = Parse path . ApStateText $ txt as - flog snk evt - unTry snk $ applyParser parser as - applyChecks snk path i.checks ds + ds <- tryAny + do + logItem snk i + as <- runAction snk action i + let !evt = Parse path . ApStateText $ txt as + flog snk evt + unTry snk $ applyParser parser as + applyChecks snk path i.checks ds + Listing {includeSteps, includeChecks} -> + do + logItem snk i + when includeSteps $ + void $ runAction snk action i + when includeChecks $ + traverse_ logChk (listChecks i.checks) + where + logChk = flog snk . Check path + + -- runTest' action parser i snk + -- if includeChecks then runChecks action parser i snk else pure () runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> LogSink -> IO () runDirectTest action i snk = - tryAny (runAction snk action i) >>= applyChecks snk path i.checks + here refactor and reuse Listing case above + tryAny (runAction snk action i) >>= applyChecks mode snk path i.checks + applyChecks :: forall ds. (Show ds) => LogSink -> Path -> Checks ds -> Either SomeException ds -> IO () -applyChecks snk p chks = +applyChecks snk p chks = either ( \e -> do log $ SkipedCheckStart p @@ -299,3 +326,4 @@ applyChecks snk p chks = (cr, ts') <- applyCheck ds ts chk logChk cr pure ts' + From 34c8974e02be0dfe971c76cc361dd4cbe022d508 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Mon, 23 Sep 2024 21:40:46 +0000 Subject: [PATCH 18/43] finished updating prepare testing pending --- src/Prepare.hs | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/Prepare.hs b/src/Prepare.hs index 3f2499a6..03e75ab9 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -9,7 +9,7 @@ module Prepare ) where -import Check (Check, Checks (..), FailStatus (NonTerminal), applyCheck, skipChecks, listChecks, CheckReport) +import Check (Check, Checks (..), FailStatus (NonTerminal), applyCheck, skipChecks, listChecks) import Control.Exception (throwIO) import Control.Exception.Extra (throw) import Control.Monad.Extra (foldM_) @@ -29,7 +29,7 @@ import DSL.Internal.NodeEvent import Data.Either.Extra (mapLeft) -- ToDO: move to Pyrelude import Internal.SuiteFiltering (FilteredSuite (..), filterSuite) import Internal.SuiteValidation (SuiteValidationError (..), chkSuite) -import PyrethrumExtras (txt, uu) +import PyrethrumExtras (txt) import UnliftIO.Exception (tryAny) -- TODO Full E2E property tests from Core fixtures and Hooks --> logs @@ -272,6 +272,17 @@ prepareTest mode interpreter rc path = runAction :: forall i as ds. (C.Item i ds) => LogSink -> (i -> m as) -> i -> IO as runAction snk action = catchLog snk . interpreter snk . action + + runListing :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> i -> LogSink -> Bool -> Bool -> IO () + runListing action i snk includeSteps includeChecks = do + logItem snk i + when includeSteps $ + void $ runAction snk action i + when includeChecks $ + traverse_ logChk (listChecks i.checks) + where + logChk = flog snk . Check path + runTest :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> ((HasCallStack) => as -> Either C.ParseException ds) -> i -> LogSink -> IO () runTest action parser i snk = case mode of @@ -286,24 +297,16 @@ prepareTest mode interpreter rc path = unTry snk $ applyParser parser as applyChecks snk path i.checks ds Listing {includeSteps, includeChecks} -> - do - logItem snk i - when includeSteps $ - void $ runAction snk action i - when includeChecks $ - traverse_ logChk (listChecks i.checks) - where - logChk = flog snk . Check path - - -- runTest' action parser i snk - -- if includeChecks then runChecks action parser i snk else pure () + runListing action i snk includeSteps includeChecks + runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> LogSink -> IO () runDirectTest action i snk = - here refactor and reuse Listing case above - tryAny (runAction snk action i) >>= applyChecks mode snk path i.checks - - + case mode of + Run -> tryAny (runAction snk action i) >>= applyChecks snk path i.checks + Listing {includeSteps, includeChecks} -> + runListing action i snk includeSteps includeChecks + applyChecks :: forall ds. (Show ds) => LogSink -> Path -> Checks ds -> Either SomeException ds -> IO () applyChecks snk p chks = either From a23320c6b3e8b86b5907fd47a20418ead3917d2e Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Mon, 23 Sep 2024 22:05:27 +0000 Subject: [PATCH 19/43] wip updated stubs --- examples/DocumenterDemo.hs | 23 +++++++++++++++++------ examples/PyrethrumBase.hs | 6 +++--- examples/WebDriverDemo.hs | 2 +- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 2fb578c4..c2ecee3f 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -51,8 +51,8 @@ runDemo runner suite = do -- putStrLn "########## Log ##########" -- atomically logList >>= mapM_ pPrint -docDemo :: Suite -> IO () -docDemo = runDemo docRunner +docDemo :: Bool -> Bool -> Suite -> IO () +docDemo stp chks = runDemo $ docRunner stp chks -- ############### Test Case ################### @@ -88,7 +88,7 @@ fsDemoAp = do -- ################### 1. FS App with full runtime ################## fsSuiteDemo :: IO () -fsSuiteDemo = docDemo fsSuite +fsSuiteDemo = docDemo True True fsSuite -- >>> fsSuiteDemo @@ -160,8 +160,20 @@ fsItems _rc = -- ################### WebDriver Test ################## -docWebDriverDemo :: IO () -docWebDriverDemo = runDemo docRunner webDriverSuite +baseWdDemo :: Bool -> Bool -> IO () +baseWdDemo stp chks = docDemo stp chks webDriverSuite + +fullDocWebdriverDemo :: IO () +fullDocWebdriverDemo = baseWdDemo True True +-- >>> fullDocWebdriverDemo + +chksDocWebdriverDemo :: IO () +chksDocWebdriverDemo = baseWdDemo False True +-- >>> chksDocWebdriverDemo + +stepsDocWebdriverDemo :: IO () +stepsDocWebdriverDemo = baseWdDemo True False +-- >>> stepsDocWebdriverDemo webDriverSuite :: Suite @@ -172,7 +184,6 @@ webDriverSuite = -- altrenative prenode for documantation -- Doc log and doc mock to make work --- >>> docWebDriverDemo test :: Fixture () test = Full config action parse items diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index dd3cf9b6..35afcddc 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -84,8 +84,8 @@ ioInterpreter sink ap = -- runConfig -- } -docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () -docRunner suite filters runConfig threadCount logControls = +docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +docRunner includeSteps includeChecks suite filters runConfig threadCount logControls = prepared & either print (\s -> executeWithoutValidation threadCount logControls s.suite) @@ -93,7 +93,7 @@ docRunner suite filters runConfig threadCount logControls = prepared :: Either SuiteValidationError (FilteredSuite (PreNode IO ())) prepared = prepare $ C.MkSuiteExeParams { interpreter = docInterpreter, - mode = C.Listing {includeSteps = True, includeChecks = True}, + mode = C.Listing {includeSteps, includeChecks}, suite = mkCoreSuite suite, filters, runConfig diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index 99de699d..0b1471f3 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -42,7 +42,7 @@ runIODemo = runDemo ioRunner -- TODO: not working looks like needs separate runner runDocDemo :: IO () -runDocDemo = runDemo docRunner +runDocDemo = runDemo $ docRunner True True -- >>> runDocDemo -- ############### Test Case ################### From c359cafefd9a23c985d6b55dff8d9fca6709b928 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Mon, 23 Sep 2024 22:11:07 +0000 Subject: [PATCH 20/43] WIP --- src/Prepare.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Prepare.hs b/src/Prepare.hs index 03e75ab9..ffb93f7d 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -272,7 +272,6 @@ prepareTest mode interpreter rc path = runAction :: forall i as ds. (C.Item i ds) => LogSink -> (i -> m as) -> i -> IO as runAction snk action = catchLog snk . interpreter snk . action - runListing :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> i -> LogSink -> Bool -> Bool -> IO () runListing action i snk includeSteps includeChecks = do logItem snk i @@ -303,7 +302,9 @@ prepareTest mode interpreter rc path = runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> LogSink -> IO () runDirectTest action i snk = case mode of - Run -> tryAny (runAction snk action i) >>= applyChecks snk path i.checks + Run -> header here >> tryAny (runAction snk action i) >>= applyChecks snk path i.checks + Do something about Action INfo and Action COnstructors + Write Hook interpreters Listing {includeSteps, includeChecks} -> runListing action i snk includeSteps includeChecks From 1105ba7fe9bec77b18117a443d28fc1cc6267cd4 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 24 Sep 2024 22:06:42 +0000 Subject: [PATCH 21/43] WIP tweaked logging start adding hooks to demo --- examples/DocumenterDemo.hs | 60 +++++++++++--- examples/FileSystemDocDemo.hs | 18 ++-- examples/IOEffectDemo.hs | 16 ++-- examples/PyrethrumBase.hs | 22 ++--- examples/PyrethrumDemoTest.hs | 5 +- examples/WebDriverDemo.hs | 6 +- examples/WebDriverDocInterpreter.hs | 4 +- pyrethrum.cabal | 4 +- pyrethrum.cabal.temp | 2 +- src/Core.hs | 2 +- src/DSL/DocInterpreterUtils.hs | 36 ++++---- src/DSL/FileSystemDocInterpreter.hs | 4 +- src/DSL/Internal/{NodeEvent.hs => NodeLog.hs} | 82 ++++++++++--------- src/DSL/Logging.hs | 6 +- src/Internal/LogQueries.hs | 10 +-- src/Internal/Logging.hs | 6 +- src/Internal/SuiteRuntime.hs | 16 ++-- src/Prepare.hs | 23 +++--- test/FullSuiteTestTemplate.hs | 2 +- test/SuiteRuntimeTestBase.hs | 14 ++-- 20 files changed, 192 insertions(+), 146 deletions(-) rename src/DSL/Internal/{NodeEvent.hs => NodeLog.hs} (59%) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index c2ecee3f..1fde84eb 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -4,8 +4,23 @@ module DocumenterDemo where import Check import Core (ParseException) +import PyrethrumBase ( + Action, + Depth (..), + Fixture (..), + HasLog, + Hook (..), + LogEffs, + Node (..), + RunConfig (..), + Suite, + FixtureConfig (..), + DataSource(..), + FixtureConfig, Country (..), Environment (..), fxCfg, + ) +import Core (After, Around, Before, Each, Once, ParseException, Thread) import DSL.FileSystemEffect -import DSL.Internal.NodeEvent (NodeEvent , Path (NodePath)) +import DSL.Internal.NodeLog (NodeLog , Path (NodePath)) import DSL.OutEffect (Out) import Data.Text (isInfixOf) import Effectful as EF @@ -27,8 +42,8 @@ import PyrethrumBase DataSource(ItemList), Depth(DeepRegression), defaultRunConfig, - docRunner ) -import PyrethrumExtras (Abs, File, relfile, toS, (?)) + docRunner, Hook (BeforeHook') ) +import PyrethrumExtras (Abs, File, relfile, toS, (?), txt) import WebDriverEffect ( WebUI, driverStatus, @@ -60,7 +75,7 @@ docDemo stp chks = runDemo $ docRunner stp chks -- copied from FileSystemDocDemo.hs -getPaths :: (Out NodeEvent :> es, FileSystem :> es) => Eff es [P.Path Abs File] +getPaths :: (Out NodeLog :> es, FileSystem :> es) => Eff es [P.Path Abs File] getPaths = do log "Getting paths" @@ -79,7 +94,7 @@ chkPathsThatDoesNothing :: [P.Path Abs File] -> Eff es () chkPathsThatDoesNothing _ = pure () -fsDemoAp :: forall es. (Out NodeEvent :> es, FileSystem :> es) => Eff es () +fsDemoAp :: forall es. (Out NodeLog :> es, FileSystem :> es) => Eff es () fsDemoAp = do paths <- getPaths chkPathsThatDoesNothing paths @@ -106,7 +121,7 @@ getFailNested = pure $ error "This is a nested error !!! " getFail :: Eff es FSAS getFail = error "This is an error !!! " -fsAction :: (FileSystem :> es, Out NodeEvent :> es) => RunConfig -> FSData -> Eff es FSAS +fsAction :: (FileSystem :> es, Out NodeLog :> es) => RunConfig -> FSData -> Eff es FSAS fsAction _rc i = do getFailNested -- getFail @@ -175,6 +190,10 @@ stepsDocWebdriverDemo :: IO () stepsDocWebdriverDemo = baseWdDemo True False -- >>> stepsDocWebdriverDemo +titlesWebdriverDemo :: IO () +titlesWebdriverDemo = baseWdDemo False False + +-- >>> titlesWebdriverDemo webDriverSuite :: Suite webDriverSuite = @@ -184,9 +203,29 @@ webDriverSuite = -- altrenative prenode for documantation -- Doc log and doc mock to make work +--- Hook --- + +nothingBefore :: Hook Once Before () () +nothingBefore = BeforeHook { + action = \_rc -> do + log "This is the outer hook" + log "Run once before the test" +} + +intOnceHook :: Hook Once Before () Int +intOnceHook = + BeforeHook' + { depends = nothingBefore + , action' = \_rc _void -> do + log "This is the inner hook" + log "Run once before the test" + pure 8 + } + +--- Fixture --- -test :: Fixture () -test = Full config action parse items +test :: Fixture Int +test = Full' config intOnceHook action parse items config :: FixtureConfig config = FxCfg "test" DeepRegression @@ -201,9 +240,10 @@ _checkBoxesLinkCss :: Selector _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" -action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS -action _rc i = do +action :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Int -> Data -> Eff es AS +action _rc hkInt i = do log $ "test title is: " <> i.title + log $ "received hook int: " <> txt hkInt <> " from the hook" status <- driver_status log "GOT DRIVER STATUS" -- log $ "the driver status is (from root): " <> txt status diff --git a/examples/FileSystemDocDemo.hs b/examples/FileSystemDocDemo.hs index 7c98c24d..365bc1b2 100644 --- a/examples/FileSystemDocDemo.hs +++ b/examples/FileSystemDocDemo.hs @@ -6,7 +6,7 @@ import DSL.FileSystemEffect findFilesWith, walkDirAccum, ) -import DSL.Internal.NodeEvent (NodeEvent (User), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (User), UserLog (Log)) import DSL.OutEffect (Out, Sink (Sink), out) import DSL.OutInterpreter ( runOut ) import Data.List.Extra (isInfixOf) @@ -14,7 +14,7 @@ import Effectful (Eff, IOE, runEff, (:>)) import Path (Abs, File, Path, absdir, reldir, relfile, toFilePath) import PyrethrumExtras ((?)) -type FSOut es = (Out NodeEvent :> es, FileSystem :> es) +type FSOut es = (Out NodeLog :> es, FileSystem :> es) -- todo - use a more believable base function @@ -32,7 +32,7 @@ runDemo :: IO () runDemo = docRun demo -- >>> runDemo -demo2 :: forall es. (Out NodeEvent :> es, FileSystem :> es) => Eff es () +demo2 :: forall es. (Out NodeLog :> es, FileSystem :> es) => Eff es () demo2 = do paths <- getPaths chk paths @@ -46,7 +46,7 @@ runDemo2 :: IO () runDemo2 = docRun demo2 -- uses -demo3 :: forall es. (Out NodeEvent :> es, FileSystem :> es) => Eff es () +demo3 :: forall es. (Out NodeLog :> es, FileSystem :> es) => Eff es () demo3 = do paths <- getPathsData chk paths @@ -59,17 +59,17 @@ demo3 = do runDemo3 :: IO () runDemo3 = docRun demo3 -docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a +docRun :: Eff '[FileSystem, Out NodeLog, IOE] a -> IO a docRun = runEff . apEventOut . DII.runFileSystem -- TODO - interpreters into own module -apEventOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a +apEventOut :: forall a es. (IOE :> es) => Eff (Out NodeLog : es) a -> Eff es a apEventOut = runOut print -log :: (Out NodeEvent :> es) => Text -> Eff es () +log :: (Out NodeLog :> es) => Text -> Eff es () log = out . User . Log -getPaths :: (Out NodeEvent :> es, FileSystem :> es) => Eff es [Path Abs File] +getPaths :: (Out NodeLog :> es, FileSystem :> es) => Eff es [Path Abs File] getPaths = do s <- findFilesWith isDeleteMe [[reldir|chris|]] [relfile|foo.txt|] @@ -87,7 +87,7 @@ data PathResult = PathResult } -- proves we are OK with strict data -getPathsData :: (Out NodeEvent :> es, FileSystem :> es) => Eff es PathResult +getPathsData :: (Out NodeLog :> es, FileSystem :> es) => Eff es PathResult getPathsData = do p <- findFilesWith isDeleteMe [[reldir|chris|]] [relfile|foo.txt|] output <- walkDirAccum Nothing (\_root _subs files -> pure files) [absdir|/pyrethrum/pyrethrum|] diff --git a/examples/IOEffectDemo.hs b/examples/IOEffectDemo.hs index ad85df72..f2e69432 100644 --- a/examples/IOEffectDemo.hs +++ b/examples/IOEffectDemo.hs @@ -7,7 +7,7 @@ import DSL.FileSystemEffect import Effectful ( IOE, type (:>), Eff, runEff ) import DSL.OutEffect import DSL.OutInterpreter ( runOut ) -import DSL.Internal.NodeEvent +import DSL.Internal.NodeLog import Data.Text qualified as T import BasePrelude (openFile, hClose, hGetContents) import DSL.FileSystemIOInterpreter ( FileSystem, runFileSystem ) @@ -101,7 +101,7 @@ timeTest = do -- use eff -listFileImp :: (FileSystem :> es, Out NodeEvent :> es) => Eff es [Text] +listFileImp :: (FileSystem :> es, Out NodeLog :> es) => Eff es [Text] listFileImp = do log "listFileImp" files <- walkDirAccum Nothing (\_root _subs files -> pure files) [absdir|/pyrethrum/pyrethrum|] @@ -109,23 +109,23 @@ listFileImp = do pure . filter ("cabal" `T.isInfixOf`) $ toS . toFilePath <$> files -apEventOut :: forall a es. (IOE :> es) => Eff (Out NodeEvent : es) a -> Eff es a +apEventOut :: forall a es. (IOE :> es) => Eff (Out NodeLog : es) a -> Eff es a apEventOut = runOut print -ioRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a +ioRun :: Eff '[FileSystem, Out NodeLog, IOE] a -> IO a ioRun ap = ap & runFileSystem & apEventOut & runEff -logShow :: (Out NodeEvent :> es, Show a) => a -> Eff es () +logShow :: (Out NodeLog :> es, Show a) => a -> Eff es () logShow = out . User . Log . txt -log :: (Out NodeEvent :> es) => Text -> Eff es () +log :: (Out NodeLog :> es) => Text -> Eff es () log = out . User . Log -- $ > ioRun effDemo -effDemo :: Eff '[FileSystem, Out NodeEvent, IOE] () +effDemo :: Eff '[FileSystem, Out NodeLog, IOE] () effDemo = do res <- listFileImp chk res @@ -133,7 +133,7 @@ effDemo = do chk _ = log "This is a effDemo" -- $ > ioRun effDemo2 -effDemo2 :: Eff '[FileSystem, Out NodeEvent, IOE] () +effDemo2 :: Eff '[FileSystem, Out NodeLog, IOE] () effDemo2 = do res <- listFileImp chk res diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 35afcddc..4e47f809 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -26,8 +26,8 @@ import Core qualified as C import DSL.FileSystemDocInterpreter qualified as FDoc (runFileSystem) import DSL.FileSystemEffect (FileSystem) import DSL.FileSystemIOInterpreter qualified as FIO (runFileSystem) -import DSL.Internal.NodeEvent (NodeEvent) -import DSL.Internal.NodeEvent qualified as AE +import DSL.Internal.NodeLog (NodeLog) +import DSL.Internal.NodeLog qualified as AE import DSL.OutEffect (Out) import DSL.OutInterpreter ( runOut ) import Effectful (Eff, IOE, runEff, type (:>)) @@ -54,16 +54,16 @@ import Internal.SuiteFiltering (FilteredSuite(..)) -- module later type Action = Eff ApEffs -type HasLog es = Out NodeEvent :> es +type HasLog es = Out NodeLog :> es -type LogEffs a = forall es. (Out NodeEvent :> es) => Eff es a +type LogEffs a = forall es. (Out NodeLog :> es) => Eff es a -type ApEffs = '[FileSystem, WebUI, Out NodeEvent, IOE] +type ApEffs = '[FileSystem, WebUI, Out NodeLog, IOE] --- type ApConstraints es = (FileSystem :> es, Out NodeEvent :> es, Error FSException :> es, IOE :> es) --- type AppEffs a = forall es. (FileSystem :> es, Out NodeEvent :> es, Error FSException :> es, IOE :> es) => Eff es a +-- type ApConstraints es = (FileSystem :> es, Out NodeLog :> es, Error FSException :> es, IOE :> es) +-- type AppEffs a = forall es. (FileSystem :> es, Out NodeLog :> es, Error FSException :> es, IOE :> es) => Eff es a -type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () ioInterpreter :: AE.LogSink -> Action a -> IO a ioInterpreter sink ap = @@ -74,7 +74,7 @@ ioInterpreter sink ap = & runEff --- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +-- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () -- docRunner suite filters runConfig threadCount logControls = -- execute threadCount logControls $ -- C.MkSuiteExeParams @@ -84,7 +84,7 @@ ioInterpreter sink ap = -- runConfig -- } -docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () docRunner includeSteps includeChecks suite filters runConfig threadCount logControls = prepared & either print @@ -101,7 +101,7 @@ docRunner includeSteps includeChecks suite filters runConfig threadCount logCont -ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> IO () +ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () ioRunner suite filters runConfig threadCount logControls = execute threadCount logControls $ C.MkSuiteExeParams diff --git a/examples/PyrethrumDemoTest.hs b/examples/PyrethrumDemoTest.hs index a3a16f9d..3ba10d63 100644 --- a/examples/PyrethrumDemoTest.hs +++ b/examples/PyrethrumDemoTest.hs @@ -1,8 +1,9 @@ module PyrethrumDemoTest where import Check (Checks, chk) +-- TODO Base should reexport all required types from core import Core (After, Around, Before, Each, Once, ParseException, Thread) -import DSL.Internal.NodeEvent (NodeEvent (..), Path (..), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (..), Path (..), UserLog (Log)) import DSL.OutEffect (out) import Effectful (Eff) import PyrethrumBase ( @@ -34,7 +35,7 @@ logShow :: (HasLog es, Show a) => a -> Eff es () logShow = out . User . Log . txt {- Demonstraits using partial effect - type LogEffs a = forall es. (Out NodeEvent :> es) => Eff es a + type LogEffs a = forall es. (Out NodeLog :> es) => Eff es a Hook has all the effects of the application but will compile with an action that only requires a sublist of these effects diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index 0b1471f3..a6f10091 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -2,7 +2,7 @@ module WebDriverDemo where import Check import Core (ParseException) -import DSL.Internal.NodeEvent (NodeEvent (User), Path (NodePath), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Log)) import DSL.OutEffect (Out, out) import Effectful as EF ( Eff, @@ -60,13 +60,13 @@ test = Full config action parse items config :: FixtureConfig config = FxCfg "test" DeepRegression -driver_status :: (WebUI :> es, Out NodeEvent :> es) => Eff es DriverStatus +driver_status :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus driver_status = do status <- driverStatus log $ "the driver status is: " <> txt status pure status -action :: (WebUI :> es, Out NodeEvent :> es) => RunConfig -> Data -> Eff es AS +action :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Data -> Eff es AS action _rc i = do log i.title status <- driver_status diff --git a/examples/WebDriverDocInterpreter.hs b/examples/WebDriverDocInterpreter.hs index c2242b59..5b57a54e 100644 --- a/examples/WebDriverDocInterpreter.hs +++ b/examples/WebDriverDocInterpreter.hs @@ -16,12 +16,12 @@ import Effectful.Dispatch.Dynamic ) import WebDriverEffect (WebUI (..)) import DSL.DocInterpreterUtils (docAction, docFake, docAction2, docFake2) -import DSL.Internal.NodeEvent (NodeEvent) +import DSL.Internal.NodeLog (NodeLog) import DSL.OutEffect ( Out ) import PyrethrumExtras (txt) import WebDriverSpec (ElementRef(..), DriverStatus (Ready), SessionRef (Session)) -runWebDriver :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Eff (WebUI : es) a -> Eff es a +runWebDriver :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es{- , E.Error DocException :> es -}) => Eff (WebUI : es) a -> Eff es a runWebDriver = interpret handler where diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 35bdfd3c..82031147 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: 78ba4888f189d6b16769757a2f3b3b7cb8ac96c8824b10c37d839689e5c9a95c +-- hash: be68a122f25a6347efe5553ecd39f294f56632f30e3c7608fbdf389abda8053d name: pyrethrum version: 0.1.0.0 @@ -88,7 +88,7 @@ library DSL.FileSystemIOInterpreter DSL.Internal.FileSystemIO DSL.Internal.FileSystemPure - DSL.Internal.NodeEvent + DSL.Internal.NodeLog DSL.Logging DSL.OutEffect DSL.OutInterpreter diff --git a/pyrethrum.cabal.temp b/pyrethrum.cabal.temp index a1c3a45e..dc3c788a 100644 --- a/pyrethrum.cabal.temp +++ b/pyrethrum.cabal.temp @@ -66,7 +66,7 @@ library DSL.FileSystemEffect DSL.FileSystemIOInterpreter DSL.FileSystemPsy - DSL.Internal.NodeEvent + DSL.Internal.NodeLog DSL.Internal.FileSystemPure DSL.Internal.FileSystemRawIO DSL.Interpreter diff --git a/src/Core.hs b/src/Core.hs index 052b9015..509f4879 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -2,7 +2,7 @@ module Core where import Check (Checks) import CoreUtils (Hz (..)) -import DSL.Internal.NodeEvent (LogSink, Path) +import DSL.Internal.NodeLog (LogSink, Path) import Data.Aeson (ToJSON (..)) import Filter (Filters) import GHC.Records (HasField) diff --git a/src/DSL/DocInterpreterUtils.hs b/src/DSL/DocInterpreterUtils.hs index 67838e49..4c52a89d 100644 --- a/src/DSL/DocInterpreterUtils.hs +++ b/src/DSL/DocInterpreterUtils.hs @@ -20,7 +20,7 @@ module DSL.DocInterpreterUtils ) where -import DSL.Internal.NodeEvent (FrameworkLog (Step), NodeEvent (..)) +import DSL.Internal.NodeLog (FrameworkLog (Step), NodeLog (..)) import DSL.OutEffect (Out, out) import Data.Text qualified as T import Effectful as EF @@ -55,13 +55,13 @@ adaptException m = EF.liftIO m `catch` \(e :: SomeException) -> E.throwError . D -- TODO: implement docVal, docHush, docVoid, docVal', or docVoid' -logStep :: (Out NodeEvent :> es) => Text -> Eff es () +logStep :: (Out NodeLog :> es) => Text -> Eff es () logStep = out . Framework . Step -logDesc :: (HasCallStack, Out NodeEvent :> es) => [Text] -> Eff es () +logDesc :: (HasCallStack, Out NodeLog :> es) => [Text] -> Eff es () logDesc = logStep . T.intercalate " " -docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> [Text] -> Eff es a +docErrn :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> [Text] -> Eff es a docErrn funcName dscFrags = logDesc dscFrags >> ( pure . error $ @@ -79,44 +79,44 @@ docErrn funcName dscFrags = -- doesn't do it now but might fix itself with GHC 9.10.00 ~ otherwise need to investigate -- pure . throw . DocException $ -docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Eff es a +docErr :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Eff es a docErr funcName funcDesc = docErrn funcName [funcDesc] -docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Eff es a +docErr2 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Text -> Eff es a docErr2 funcName funcDesc1 funcDesc2 = docErrn funcName [funcDesc1, funcDesc2] -docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Eff es a +docErr3 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Text -> Text -> Eff es a docErr3 funcName funcDesc1 funcDesc2 funcDesc3 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3] -docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Text -> Eff es a +docErr4 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Text -> Text -> Text -> Eff es a docErr4 funcName funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docErrn funcName [funcDesc1, funcDesc2, funcDesc3, funcDesc4] -docActionn :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => [Text] -> Eff es () +docActionn :: forall es. (HasCallStack, IOE :> es, Out NodeLog :> es) => [Text] -> Eff es () docActionn dscFrags = logStep $ T.intercalate " " dscFrags -docAction :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Eff es () +docAction :: forall es. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Eff es () docAction funcDesc = docActionn [funcDesc] -docAction2 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Eff es () +docAction2 :: forall es. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Eff es () docAction2 funcDesc1 funcDesc2 = docActionn [funcDesc1, funcDesc2] -docAction3 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Eff es () +docAction3 :: forall es. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Text -> Eff es () docAction3 funcDesc1 funcDesc2 funcDesc3 = docActionn [funcDesc1, funcDesc2, funcDesc3] -docAction4 :: forall es. (HasCallStack, IOE :> es, Out NodeEvent :> es) => Text -> Text -> Text -> Text -> Eff es () +docAction4 :: forall es. (HasCallStack, IOE :> es, Out NodeLog :> es) => Text -> Text -> Text -> Text -> Eff es () docAction4 funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docActionn [funcDesc1, funcDesc2, funcDesc3, funcDesc4] -docFaken :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> [Text] -> Eff es a +docFaken :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => a -> [Text] -> Eff es a docFaken a dscFrags = logDesc dscFrags >> pure a -docFake :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Eff es a +docFake :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => a -> Text -> Eff es a docFake a funcDesc = docFaken a [funcDesc] -docFake2 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Eff es a +docFake2 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => a -> Text -> Text -> Eff es a docFake2 a funcDesc1 funcDesc2 = docFaken a [funcDesc1, funcDesc2] -docFake3 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Text -> Eff es a +docFake3 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => a -> Text -> Text -> Text -> Eff es a docFake3 a funcDesc1 funcDesc2 funcDesc3 = docFaken a [funcDesc1, funcDesc2, funcDesc3] -docFake4 :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es) => a -> Text -> Text -> Text -> Text -> Eff es a +docFake4 :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es) => a -> Text -> Text -> Text -> Text -> Eff es a docFake4 a funcDesc1 funcDesc2 funcDesc3 funcDesc4 = docFaken a [funcDesc1, funcDesc2, funcDesc3, funcDesc4] diff --git a/src/DSL/FileSystemDocInterpreter.hs b/src/DSL/FileSystemDocInterpreter.hs index 454efbd2..7146ae64 100644 --- a/src/DSL/FileSystemDocInterpreter.hs +++ b/src/DSL/FileSystemDocInterpreter.hs @@ -16,11 +16,11 @@ import Path.Extended (Path, toFilePath) import PyrethrumExtras (toS, txt, (?)) import Effectful.Dispatch.Dynamic (LocalEnv, interpret) import DSL.DocInterpreterUtils (docErr, docErr2, docErr3, docErr4) -import DSL.Internal.NodeEvent (NodeEvent) +import DSL.Internal.NodeLog (NodeLog) -- TODO: implement docVal, docHush, docVoid, docVal', or docVoid' -runFileSystem :: forall es a. (HasCallStack, IOE :> es, Out NodeEvent :> es{- , E.Error DocException :> es -}) => Eff (FileSystem : es) a -> Eff es a +runFileSystem :: forall es a. (HasCallStack, IOE :> es, Out NodeLog :> es{- , E.Error DocException :> es -}) => Eff (FileSystem : es) a -> Eff es a runFileSystem = interpret handler where diff --git a/src/DSL/Internal/NodeEvent.hs b/src/DSL/Internal/NodeLog.hs similarity index 59% rename from src/DSL/Internal/NodeEvent.hs rename to src/DSL/Internal/NodeLog.hs index 875dc427..7c6393ca 100644 --- a/src/DSL/Internal/NodeEvent.hs +++ b/src/DSL/Internal/NodeLog.hs @@ -1,76 +1,80 @@ {-# LANGUAGE DeriveAnyClass #-} -module DSL.Internal.NodeEvent where + +module DSL.Internal.NodeLog where import Check (CheckReport) import Data.Aeson.TH (defaultOptions, deriveJSON) import PyrethrumExtras (toS) -type LogSink = NodeEvent -> IO () +type LogSink = NodeLog -> IO () + -- TODO: Note plugin {- -NodeEvent is a data type that represents specfic types of events loggged from WITHIN a node (ie. a Hook or a Fixture) -eg. +NodeLog is a data type that represents specfic types of events loggged from WITHIN a node (ie. a Hook or a Fixture) +eg. - starting a test action - executing checks - user logs This is distinct from the Events emited by the Suite Runtime that mark the boundaries of these actions -eg. +eg. - start of test - end of hook - filter log - end suite execution - + User UserLog -> ad hoc logging implemented by users of the framework Framework FrameworkLog -> internal events from within a test or hook such as the start of a test phase such as action, parse and checks -} -data NodeEvent +data NodeLog = User UserLog | Framework FrameworkLog deriving (Show, Generic, NFData) - -newtype ItemText = ItemText {text :: Text} +newtype ItemText = ItemText {text :: Text} deriving (Eq, Show) deriving newtype (IsString, NFData) -newtype DStateText = DStateText {text :: Text} +newtype DStateText = DStateText {text :: Text} deriving (Eq, Show) - deriving newtype (IsString, NFData) + deriving newtype (IsString, NFData) -- framework logs that represent test fixtures have a path to that fixture -- Steps and Exceptions do not as they don't represent test fixture data FrameworkLog - = Action + = Test + { path :: Path, + item :: ItemText + } + | ActionStart { path :: Path - , item :: ItemText } | Parse - { path :: Path - , apState :: ApStateText + { path :: Path, + apState :: ApStateText } | CheckStart - { path :: Path - , dState :: DStateText + { path :: Path, + dState :: DStateText } | SkipedCheckStart { path :: Path } | Check - { path :: Path - , report :: CheckReport + { path :: Path, + report :: CheckReport } | Step { message :: Text } | Step' - { message :: Text - , details :: Text + { message :: Text, + details :: Text } | Exception - { exception :: Text - , callStack :: Text + { exception :: Text, + callStack :: Text } deriving (Show, Generic, NFData) @@ -79,48 +83,46 @@ data UserLog | EndFolder Text | Log Text | Log' - { message :: Text - , details :: Text + { message :: Text, + details :: Text } | Warning Text | Warning' - { message :: Text - , details :: Text + { message :: Text, + details :: Text } | Error Text | Error' - { message :: Text - , details :: Text + { message :: Text, + details :: Text } deriving (Eq, Show, Generic, NFData) data Path = NodePath - { module' :: Text - , path :: Text + { module' :: Text, + path :: Text } | TestPath - { id :: Int - , title :: Text + { id :: Int, + title :: Text } deriving (Show, Eq, Ord, Generic, NFData) - -newtype ApStateText = ApStateText {text :: Text} - deriving (Eq, Show) - deriving newtype (IsString, NFData) +newtype ApStateText = ApStateText {text :: Text} + deriving (Eq, Show) + deriving newtype (IsString, NFData) $(deriveJSON defaultOptions ''ApStateText) - $(deriveJSON defaultOptions ''DStateText) $(deriveJSON defaultOptions ''ItemText) -exceptionEvent :: Exception e => e -> CallStack -> NodeEvent +exceptionEvent :: (Exception e) => e -> CallStack -> NodeLog exceptionEvent e cs = Framework $ Exception (toS $ displayException e) (toS $ prettyCallStack cs) $(deriveJSON defaultOptions ''UserLog) $(deriveJSON defaultOptions ''Path) $(deriveJSON defaultOptions ''FrameworkLog) -$(deriveJSON defaultOptions ''NodeEvent) \ No newline at end of file +$(deriveJSON defaultOptions ''NodeLog) \ No newline at end of file diff --git a/src/DSL/Logging.hs b/src/DSL/Logging.hs index 244d6166..e9051887 100644 --- a/src/DSL/Logging.hs +++ b/src/DSL/Logging.hs @@ -4,7 +4,7 @@ module DSL.Logging ( ) where import DSL.OutEffect -import DSL.Internal.NodeEvent qualified as E +import DSL.Internal.NodeLog qualified as E import Effectful as EF ( Eff, type (:>), @@ -13,8 +13,8 @@ import PyrethrumExtras (txt) {- TODO Other efect funtions such as warning and folder -} -logTxt :: (Out E.NodeEvent :> es, Show a) => a -> Eff es () +logTxt :: (Out E.NodeLog :> es, Show a) => a -> Eff es () logTxt = log . txt -log :: (Out E.NodeEvent :> es) => Text -> Eff es () +log :: (Out E.NodeLog :> es) => Text -> Eff es () log = out . E.User . E.Log \ No newline at end of file diff --git a/src/Internal/LogQueries.hs b/src/Internal/LogQueries.hs index 18f9331b..defd0778 100644 --- a/src/Internal/LogQueries.hs +++ b/src/Internal/LogQueries.hs @@ -85,7 +85,7 @@ startEndNodeMatch p l = evnt l & \case StartExecution {} -> False Failure {} -> False ParentFailure {} -> False - NodeEvent {} -> False + NodeLog {} -> False EndExecution {} -> False FilterLog {} -> False SuiteInitFailure {} -> False @@ -115,7 +115,7 @@ suiteEventOrParentFailureSuiteEvent l = End {nodeType = s} -> Just s Failure {} -> Nothing ParentFailure {nodeType = s} -> Just s - NodeEvent {} -> Nothing + NodeLog {} -> Nothing EndExecution {} -> Nothing getSuiteEvent :: Log a b -> Maybe NodeType @@ -127,7 +127,7 @@ getSuiteEvent l = evnt l & \case ParentFailure {nodeType} -> Just nodeType Failure {nodeType} -> Just nodeType StartExecution {} -> Nothing - NodeEvent {} -> Nothing + NodeLog {} -> Nothing EndExecution {} -> Nothing getHookInfo :: Log a b -> Maybe (Hz, HookPos) @@ -142,7 +142,7 @@ startOrParentFailure l = evnt l & \case SuiteInitFailure {} -> False StartExecution {} -> False EndExecution {} -> False - NodeEvent {} -> False + NodeLog {} -> False Failure {} -> False -- event will either have a start or be -- represented by a parent failure if skipped @@ -156,7 +156,7 @@ startSuiteEventLoc l = evnt l & \case SuiteInitFailure {} -> Nothing StartExecution {} -> Nothing EndExecution {} -> Nothing - NodeEvent {} -> Nothing + NodeLog {} -> Nothing Failure {} -> Nothing -- event will either have a start or be -- represented by a parent failure if skipped diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 10faa916..f8934131 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -6,7 +6,7 @@ module Internal.Logging where import CoreUtils (Hz (..)) import CoreUtils qualified as C -import DSL.Internal.NodeEvent qualified as NE +import DSL.Internal.NodeLog qualified as NE import Data.Aeson.TH (defaultOptions, deriveJSON, deriveToJSON) import Data.Text as T (intercalate) import Filter (FilterResult) @@ -215,7 +215,7 @@ data Event loc evnt failLoc :: loc, failSuiteEvent :: NodeType } - | NodeEvent + | NodeLog { event :: evnt } | EndExecution @@ -224,7 +224,7 @@ data Event loc evnt testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) testLogControls = testLogControls' expandEvent --- -- NodeEvent (a) a loggable event generated from within a node +-- -- NodeLog (a) a loggable event generated from within a node -- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors -- -- Log a - adds thread id and index to EngineEvent expandEvent :: C.ThreadId -> Int -> Event l a -> Log l a diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index fa26cb43..1e7129be 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -2,7 +2,7 @@ module Internal.SuiteRuntime where import Core qualified as C import CoreUtils (Hz (..)) -import DSL.Internal.NodeEvent qualified as AE +import DSL.Internal.NodeLog qualified as AE import Internal.Logging (HookPos (..), NodeType (..)) import Internal.Logging qualified as L import Internal.SuiteFiltering (FilteredSuite (..)) @@ -36,15 +36,15 @@ newtype ThreadCount = ThreadCount {maxThreads :: Int} -- executes prenodes directly without any tree shaking, -- filtering or validation used in testing -executeWithoutValidation :: ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> [P.PreNode IO ()] -> IO () +executeWithoutValidation :: ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> [P.PreNode IO ()] -> IO () executeWithoutValidation tc lc pn = L.runWithLogger lc (\l -> executeNodeList tc l pn) -execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeEvent) (L.Log L.ExePath AE.NodeEvent) -> C.SuiteExeParams m rc fc -> IO () +execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> C.SuiteExeParams m rc fc -> IO () execute tc lc prms = L.runWithLogger lc execute' where - execute' :: L.LoggerSource (L.Event L.ExePath AE.NodeEvent) -> IO () + execute' :: L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> IO () execute' l@L.MkLoggerSource{rootLogger} = do P.prepare prms @@ -56,13 +56,13 @@ execute tc lc prms = executeNodeList tc l validated.suite ) -executeNodeList :: ThreadCount -> L.LoggerSource (L.Event L.ExePath AE.NodeEvent) -> [P.PreNode IO ()] -> IO () +executeNodeList :: ThreadCount -> L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> [P.PreNode IO ()] -> IO () executeNodeList tc lgr nodeList = do xtree <- mkXTree (L.ExePath []) nodeList executeNodes lgr xtree tc -executeNodes :: L.LoggerSource (L.Event L.ExePath AE.NodeEvent) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () +executeNodes :: L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () executeNodes L.MkLoggerSource {rootLogger, newLogger} nodes tc = do finally @@ -356,7 +356,7 @@ data ExeIn oi ti tsti = ExeIn tstIn :: tsti } -type Logger = L.Event L.ExePath AE.NodeEvent -> IO () +type Logger = L.Event L.ExePath AE.NodeLog -> IO () logAbandonned :: Logger -> L.ExePath -> NodeType -> L.FailPoint -> IO () logAbandonned lgr p e a = @@ -607,7 +607,7 @@ runNode lgr hi xt = invalidTree input cst = bug @Void . error $ input <> " >>> should not be passed to >>> " <> cst <> "\n" <> txt xt.path sink :: P.LogSink - sink = lgr . L.NodeEvent + sink = lgr . L.NodeLog runTestsWithEachContext :: forall ti. IO (TestContext ti) -> TestSource ti -> IO QElementRun runTestsWithEachContext ctx = diff --git a/src/Prepare.hs b/src/Prepare.hs index ffb93f7d..3a093a86 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -16,13 +16,13 @@ import Control.Monad.Extra (foldM_) import Core (Mode (..), SuiteExeParams) import Core qualified as C import CoreUtils (Hz) -import DSL.Internal.NodeEvent +import DSL.Internal.NodeLog ( ApStateText (ApStateText), DStateText (DStateText), - FrameworkLog (Action, Check, CheckStart, Parse, SkipedCheckStart), + FrameworkLog (..), ItemText (ItemText), LogSink, - NodeEvent (Framework), + NodeLog (Framework), Path, exceptionEvent, ) @@ -266,15 +266,20 @@ prepareTest mode interpreter rc path = applyParser :: forall as ds. ((HasCallStack) => as -> Either C.ParseException ds) -> as -> Either SomeException ds applyParser parser as = mapLeft toException $ parser as - logItem :: forall i. (Show i) => LogSink -> i -> IO () - logItem snk = flog snk . Action path . ItemText . txt + logTest :: forall i. (Show i) => LogSink -> i -> IO () + logTest snk = flog snk . Test path . ItemText . txt + + logTestAndAction :: forall i. (Show i) => LogSink -> i -> IO () + logTestAndAction snk i = do + logTest snk i + flog snk $ ActionStart path runAction :: forall i as ds. (C.Item i ds) => LogSink -> (i -> m as) -> i -> IO as runAction snk action = catchLog snk . interpreter snk . action runListing :: forall i as ds. (Show as, C.Item i ds) => (i -> m as) -> i -> LogSink -> Bool -> Bool -> IO () runListing action i snk includeSteps includeChecks = do - logItem snk i + logTest snk i when includeSteps $ void $ runAction snk action i when includeChecks $ @@ -289,7 +294,7 @@ prepareTest mode interpreter rc path = do ds <- tryAny do - logItem snk i + logTestAndAction snk i as <- runAction snk action i let !evt = Parse path . ApStateText $ txt as flog snk evt @@ -302,9 +307,7 @@ prepareTest mode interpreter rc path = runDirectTest :: forall i ds. (C.Item i ds) => (i -> m ds) -> i -> LogSink -> IO () runDirectTest action i snk = case mode of - Run -> header here >> tryAny (runAction snk action i) >>= applyChecks snk path i.checks - Do something about Action INfo and Action COnstructors - Write Hook interpreters + Run -> logTestAndAction snk i >> tryAny (runAction snk action i) >>= applyChecks snk path i.checks Listing {includeSteps, includeChecks} -> runListing action i snk includeSteps includeChecks diff --git a/test/FullSuiteTestTemplate.hs b/test/FullSuiteTestTemplate.hs index 4561f662..c792fc01 100644 --- a/test/FullSuiteTestTemplate.hs +++ b/test/FullSuiteTestTemplate.hs @@ -1,6 +1,6 @@ module FullSuiteTestTemplate where -import DSL.Internal.NodeEvent (Path (..)) +import DSL.Internal.NodeLog (Path (..)) import Data.Map.Strict qualified as Map import CoreUtils (Hz (..)) import Internal.Logging (HookPos (..), NodeType (Hook)) diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index 4854667e..aea1baf0 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -7,7 +7,7 @@ import Chronos (Time, now) import Core (DataSource (ItemList)) import Core qualified import CoreUtils (Hz (..), ThreadId) -import DSL.Internal.NodeEvent qualified as AE +import DSL.Internal.NodeLog qualified as AE import Data.Aeson (ToJSON) import Data.Hashable qualified as H import Data.Map.Strict qualified as M @@ -126,7 +126,7 @@ https://hackage.haskell.org/package/Agda-2.6.4.3/Agda-2.6.4.3.tar.gz $ cabal install -f +optimise-heavily -f +enable-cluster-counting -} -type LogItem = Log ExePath AE.NodeEvent +type LogItem = Log ExePath AE.NodeLog getThreadId :: LogItem -> ThreadId getThreadId (MkLog (MkLogContext {threadId}) _) = threadId @@ -239,7 +239,7 @@ logAccum acc@(passStart, rMap) (MkLog {event}) = FilterLog {} -> acc SuiteInitFailure {} -> acc StartExecution {} -> acc - NodeEvent {} -> acc + NodeLog {} -> acc EndExecution {} -> acc where insert' :: ExePath -> NodeType -> LogResult -> Map EventPath [LogResult] @@ -529,7 +529,7 @@ failInfo ls = ParentFailure {} -> passThrough StartExecution {} -> passThrough EndExecution {} -> passThrough - NodeEvent {} -> passThrough + NodeLog {} -> passThrough End {} -> passThrough where passThrough = (lastStartEvnt, result) @@ -751,7 +751,7 @@ threadedLogs onceHookInclude l = shouldOccurOnce :: LogItem -> Bool shouldOccurOnce = startEndNodeMatch onceSuiteEvent -chkStartEndExecution :: [Log ExePath AE.NodeEvent] -> IO () +chkStartEndExecution :: [Log ExePath AE.NodeLog] -> IO () chkStartEndExecution evts = (,) <$> PE.head evts @@ -856,7 +856,7 @@ test = Spec 0 data ExeResult = ExeResult { expandedTemplate :: [T.Template], - log :: [Log ExePath AE.NodeEvent] + log :: [Log ExePath AE.NodeLog] } runTest :: Int -> ThreadCount -> [Template] -> IO () @@ -886,7 +886,7 @@ execute wantLog baseRandomSeed threadLimit templates = do lg <- exeTemplate wantLog baseRandomSeed threadLimit fullTs pure $ ExeResult fullTs lg -exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [Log ExePath AE.NodeEvent] +exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [Log ExePath AE.NodeLog] exeTemplate wantLog baseRandomSeed maxThreads templates = do let wantLog' = wantLog == Log (lc, logLst) <- testLogControls wantLog' From c8254cbb13e3f7e22a3084a817d04a5f4ff4100a Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Tue, 24 Sep 2024 22:08:39 +0000 Subject: [PATCH 22/43] WIP --- examples/DocumenterDemo.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 1fde84eb..652b8961 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -195,6 +195,11 @@ titlesWebdriverDemo = baseWdDemo False False -- >>> titlesWebdriverDemo +TODO: + - get demo working with hooks + - add tests + - play with hook data objects and laziness + webDriverSuite :: Suite webDriverSuite = [Fixture (NodePath "WebDriverDemo" "test") test] From d0a9847acb6dd693fa1321d968cf8742925fda12 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 26 Sep 2024 20:28:21 +0000 Subject: [PATCH 23/43] clean up reduce redundant dependencies --- examples/DocumenterDemo.hs | 134 +++++++++++++--------------- examples/WebDriverDemo.hs | 81 +++++++++++++---- examples/WebDriverDocInterpreter.hs | 2 +- examples/WebDriverIO.hs | 106 ++++++++++------------ examples/WebDriverSpec.hs | 86 ++++++++++-------- package.yaml | 4 +- pyrethrum.cabal | 4 +- src/Prepare.hs | 6 +- 8 files changed, 229 insertions(+), 194 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 652b8961..262dcd5f 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -1,26 +1,10 @@ -{-# LANGUAGE NoStrictData #-} - module DocumenterDemo where import Check -import Core (ParseException) -import PyrethrumBase ( - Action, - Depth (..), - Fixture (..), - HasLog, - Hook (..), - LogEffs, - Node (..), - RunConfig (..), - Suite, - FixtureConfig (..), - DataSource(..), - FixtureConfig, Country (..), Environment (..), fxCfg, - ) -import Core (After, Around, Before, Each, Once, ParseException, Thread) +import Core (Before, Once, ParseException) import DSL.FileSystemEffect -import DSL.Internal.NodeLog (NodeLog , Path (NodePath)) +import DSL.Internal.NodeLog (NodeLog, Path (NodePath)) +import DSL.Logging ( log ) import DSL.OutEffect (Out) import Data.Text (isInfixOf) import Effectful as EF @@ -31,48 +15,48 @@ import Filter (Filters (..)) import Internal.Logging qualified as L import Internal.SuiteRuntime (ThreadCount (..)) import Path as P (Path, reldir, toFilePath) -import DSL.Logging import PyrethrumBase - ( SuiteRunner, - Suite, - RunConfig, - FixtureConfig(FxCfg), - Fixture(Full), - Node(Fixture), - DataSource(ItemList), - Depth(DeepRegression), - defaultRunConfig, - docRunner, Hook (BeforeHook') ) -import PyrethrumExtras (Abs, File, relfile, toS, (?), txt) + ( DataSource (..), + Depth (..), + Fixture (..), + FixtureConfig (..), + Hook (..), + Node (..), + RunConfig (..), + Suite, + SuiteRunner, + defaultRunConfig, + docRunner, + ) +import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) import WebDriverEffect - ( WebUI, - driverStatus, - newSession, - maximiseWindow, - go, - findElem, - readElem, - clickElem, - sleep, - killSession ) + ( WebUI, + clickElem, + driverStatus, + findElem, + go, + killSession, + maximiseWindow, + newSession, + readElem, + sleep, + ) import WebDriverPure (seconds) import WebDriverSpec (DriverStatus (..), Selector (CSS)) - runDemo :: SuiteRunner -> Suite -> IO () runDemo runner suite = do (logControls, _logList) <- L.testLogControls True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls - -- putStrLn "########## Log ##########" - -- atomically logList >>= mapM_ pPrint + +-- putStrLn "########## Log ##########" +-- atomically logList >>= mapM_ pPrint docDemo :: Bool -> Bool -> Suite -> IO () docDemo stp chks = runDemo $ docRunner stp chks -- ############### Test Case ################### - - -- copied from FileSystemDocDemo.hs getPaths :: (Out NodeLog :> es, FileSystem :> es) => Eff es [P.Path Abs File] @@ -89,17 +73,14 @@ getPaths = isDeleteMe :: P.Path Abs File -> Eff es Bool isDeleteMe = pure . isInfixOf "deleteMe" . toS . P.toFilePath - chkPathsThatDoesNothing :: [P.Path Abs File] -> Eff es () chkPathsThatDoesNothing _ = pure () - fsDemoAp :: forall es. (Out NodeLog :> es, FileSystem :> es) => Eff es () fsDemoAp = do paths <- getPaths chkPathsThatDoesNothing paths - -- ################### 1. FS App with full runtime ################## fsSuiteDemo :: IO () @@ -138,7 +119,7 @@ data FSData = FSItem } deriving (Show, Read) -{- +{- TODO: make better compile error example data FSData = FSItem { id :: Int, @@ -172,7 +153,6 @@ fsItems _rc = } ] - -- ################### WebDriver Test ################## baseWdDemo :: Bool -> Bool -> IO () @@ -180,14 +160,17 @@ baseWdDemo stp chks = docDemo stp chks webDriverSuite fullDocWebdriverDemo :: IO () fullDocWebdriverDemo = baseWdDemo True True + -- >>> fullDocWebdriverDemo chksDocWebdriverDemo :: IO () -chksDocWebdriverDemo = baseWdDemo False True +chksDocWebdriverDemo = baseWdDemo False True + -- >>> chksDocWebdriverDemo stepsDocWebdriverDemo :: IO () stepsDocWebdriverDemo = baseWdDemo True False + -- >>> stepsDocWebdriverDemo titlesWebdriverDemo :: IO () @@ -195,36 +178,43 @@ titlesWebdriverDemo = baseWdDemo False False -- >>> titlesWebdriverDemo -TODO: - - get demo working with hooks - - add tests - - play with hook data objects and laziness +-- TODO: +-- - add tests +-- - play with hook data objects and laziness webDriverSuite :: Suite webDriverSuite = - [Fixture (NodePath "WebDriverDemo" "test") test] + [ Hook + (NodePath "WebDriverDemo" "before") + nothingBefore + [ Hook + (NodePath "WebDriverDemo" "beforeInner") + intOnceHook + [ Fixture (NodePath "WebDriverDemo" "test") test + ] + ] + ] --- todo experiment with hooks (laziness) --- altrenative prenode for documantation --- Doc log and doc mock to make work --- Hook --- nothingBefore :: Hook Once Before () () -nothingBefore = BeforeHook { - action = \_rc -> do - log "This is the outer hook" - log "Run once before the test" -} +nothingBefore = + BeforeHook + { action = \_rc -> do + log "This is the outer hook" + log "Run once before the test" + } intOnceHook :: Hook Once Before () Int intOnceHook = BeforeHook' - { depends = nothingBefore - , action' = \_rc _void -> do - log "This is the inner hook" - log "Run once before the test" - pure 8 + { depends = nothingBefore, + action' = \_rc _void -> do + log "This is the inner hook" + log "Run once before the test" + pure 8 + -- pure $ error "HOOK BANG !!!" } --- Fixture --- @@ -236,7 +226,8 @@ config :: FixtureConfig config = FxCfg "test" DeepRegression driver_status :: (WebUI :> es) => Eff es DriverStatus -driver_status = driverStatus +driver_status = pure $ error "This is a lazy error !!!" +-- driver_status = driverStatus _theInternet :: Text _theInternet = "https://the-internet.herokuapp.com/" @@ -244,7 +235,6 @@ _theInternet = "https://the-internet.herokuapp.com/" _checkBoxesLinkCss :: Selector _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" - action :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Int -> Data -> Eff es AS action _rc hkInt i = do log $ "test title is: " <> i.title diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index a6f10091..a46ab6c4 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -16,6 +16,7 @@ import Filter (Filters(..)) import Internal.SuiteRuntime (ThreadCount(..)) import Internal.Logging qualified as L import WebDriverPure (seconds) +import DSL.Logging (log) -- ################### Effectful Demo ################## @@ -30,29 +31,18 @@ suite :: Suite suite = [Fixture (NodePath "WebDriverDemo" "test") test] -runDemo :: SuiteRunner -> IO () -runDemo runner = do +runDemo :: SuiteRunner -> Suite -> IO () +runDemo runner suite' = do (logControls, _logLst) <- L.testLogControls True - runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls + runner suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls -- start geckodriver first: geckodriver & -runIODemo :: IO () +runIODemo :: Suite -> IO () runIODemo = runDemo ioRunner --- >>> runIODemo - --- TODO: not working looks like needs separate runner -runDocDemo :: IO () -runDocDemo = runDemo $ docRunner True True --- >>> runDocDemo -- ############### Test Case ################### --- TODO: log interpreter -logShow :: (HasLog es, Show a) => a -> Eff es () -logShow = log . txt - -log :: (HasLog es) => Text -> Eff es () -log = out . User . Log +-- >>> runIODemo suite test :: Fixture () test = Full config action parse items @@ -116,3 +106,62 @@ items _rc = } ] +-- ############### Test Case With Lazy Errors ################### + +{- +todo: + - exceptions in selenium + - check why no callstack + - laziness - esp hooks + - finish doc interpreter poc + - merge +-} + +--- >>> lazyDemo +lazyDemo :: IO () +lazyDemo = runIODemo suiteLzFail + +suiteLzFail :: Suite +suiteLzFail = + [Fixture (NodePath "WebDriverDemo" "test") testLazy] + + +testLazy :: Fixture () +testLazy = Full config action_fail parseLzFail itemsLzFail + +driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus +driver_status_fail = do + status <- driverStatus + log $ "the driver status is: " <> txt status + pure $ error "BANG !!!! driver status failed !!!" + +action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Data -> Eff es AS +action_fail _rc i = do + log i.title + status <- driver_status_fail + -- log $ "the driver status is (from test): " <> txt status + ses <- newSession + maximiseWindow ses + go ses _theInternet + link <- findElem ses _checkBoxesLinkCss + checkButtonText <- readElem ses link + clickElem ses link + -- so we can see the navigation worked + sleep $ 5 * seconds + killSession ses + pure $ AS {status, checkButtonText} + +parseLzFail :: AS -> Either ParseException DS +parseLzFail AS {..} = pure $ DS {..} + +itemsLzFail :: RunConfig -> DataSource Data +itemsLzFail _rc = + ItemList + [ Item + { id = 1, + title = "test the internet", + checks = + chk "Driver is ready" ((== Ready) . (.status)) + <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) + } + ] diff --git a/examples/WebDriverDocInterpreter.hs b/examples/WebDriverDocInterpreter.hs index 5b57a54e..6bec069d 100644 --- a/examples/WebDriverDocInterpreter.hs +++ b/examples/WebDriverDocInterpreter.hs @@ -41,7 +41,7 @@ runWebDriver = -- window FullscreenWindow _sessionRef -> docAction "make browser fullscreen" MaximiseWindow _sessionRef -> docAction "maximise browser window" - MinimiseWindow _sessionRef -> docAction"minimise browser window" + MinimiseWindow _sessionRef -> docAction "minimise browser window" -- navigate Go _sessionRef url -> docAction2 "navigate to:" url -- page diff --git a/examples/WebDriverIO.hs b/examples/WebDriverIO.hs index de2a85ed..132b0165 100644 --- a/examples/WebDriverIO.hs +++ b/examples/WebDriverIO.hs @@ -19,11 +19,9 @@ where import Data.Aeson (Value, object) import Data.Text.IO qualified as T -import Network.HTTP.Client qualified as L import Network.HTTP.Req as R ( DELETE (DELETE), GET (GET), - HttpException, NoReqBody (NoReqBody), POST (POST), ReqBodyJson (ReqBodyJson), @@ -35,15 +33,13 @@ import Network.HTTP.Req as R port, req, responseBody, - responseCookieJar, responseStatusCode, responseStatusMessage, runReq, - toVanillaResponse, (/:), ) import PyrethrumExtras (getLenient, toS, txt) -import UnliftIO (try) +-- import UnliftIO (try) -- TODO deprecate import Web.Api.WebDriver (Capabilities, defaultFirefoxCapabilities) import WebDriverPure (RequestArgs (..), capsToJson) @@ -61,7 +57,6 @@ import WebDriverSpec as WD fullscreenWindowSpec, maximizeWindowSpec, minimizeWindowSpec, - mkShowable, navigateToSpec, newSessionSpec', statusSpec, @@ -105,34 +100,9 @@ elementText s = run . elementTextSpec s -- ############# Utils ############# --- TODO: logging behaviour injectable special value W3CLogging --- eg. thsi can scramble logs when run in Eff and multithreaded --------------------------------------------------------------------------------- --- console out (to haskell output window) for debugging -run :: forall a. (Show a) => W3Spec a -> IO a -run = execute' - --- | Execute with logging -execute' :: forall a. (Show a) => W3Spec a -> IO a -execute' spec = - describe spec.description $ do - devLog . txt $ mkShowable spec - r <- callWebDriver True $ mkRequest spec - parseIO spec r --------------------------------------------------------------------------------- - -{- --------------------------------------------------------------------------------- -- no console out for "production" run :: W3Spec a -> IO a -run = execute - -execute :: forall a. W3Spec a -> IO a -execute spec = do - r <- callWebDriver False $ mkRequest spec - parseIO spec r --------------------------------------------------------------------------------- --} +run spec = callWebDriver False (mkRequest spec) >>= parseIO spec -- TODO: will neeed to be parameterised later mkRequest :: forall a. W3Spec a -> RequestArgs @@ -144,10 +114,10 @@ mkRequest = \case parseIO :: W3Spec a -> WD.HttpResponse -> IO a parseIO spec r = - maybe - (fail . toS $ spec.description <> "\n" <> "Failed to parse response:\n " <> txt r) - pure - $ spec.parser r + spec.parser r + & maybe + (fail . toS $ spec.description <> "\n" <> "Failed to parse response:\n " <> txt r) + pure devLog :: (MonadIO m) => Text -> m () devLog = liftIO . T.putStrLn @@ -161,9 +131,10 @@ callWebDriver wantLog RequestParams {subDirs, method, body, port = prt} = Response { statusCode = responseStatusCode r, statusMessage = getLenient . toS $ responseStatusMessage r, - headers = L.responseHeaders . toVanillaResponse $ r, - body = responseBody r :: Value, - cookies = responseCookieJar r + body = responseBody r :: Value + -- not used yet may be able to remove and reduce dependncies + -- headers = L.responseHeaders . toVanillaResponse $ r, + -- cookies = responseCookieJar r } log $ "Framework Response:\n" <> txt fr pure fr @@ -172,25 +143,38 @@ callWebDriver wantLog RequestParams {subDirs, method, body, port = prt} = url :: Url 'Http url = foldl' (/:) (http "127.0.0.1") subDirs -describe :: (Show a) => Text -> IO a -> IO a -describe msg action = do - T.putStrLn "" - T.putStrLn $ "########### " <> msg <> " ###########" - ethr <- handleEx action - logResponse ethr - either (fail . toS . txt) pure ethr - -handleEx :: IO a -> IO (Either HttpException a) -handleEx = try - -logResponse :: (Show a) => Either HttpException a -> IO () -logResponse = - either - ( \e -> do - T.putStrLn "!!!!!!!!!! REQUEST FAILED !!!!!!!!!!!" - T.putStrLn $ txt e - ) - ( \r -> do - T.putStrLn "!!!!!!!!!! REQUEST SUCCEEDED !!!!!!!!!!!" - T.putStrLn $ txt r - ) \ No newline at end of file + +-------------------------------------------------------------------------------- +-- console out (to haskell output window) for debugging +-- run :: forall a. (Show a) => W3Spec a -> IO a +-- run spec = +-- describe spec.description $ do +-- devLog . txt $ mkShowable spec +-- r <- callWebDriver True $ mkRequest spec +-- parseIO spec r + + +-- describe :: (Show a) => Text -> IO a -> IO a +-- describe msg action = do +-- T.putStrLn "" +-- T.putStrLn $ "########### " <> msg <> " ###########" +-- ethr <- handleEx action +-- logResponse ethr +-- either (fail . toS . txt) pure ethr + +-- handleEx :: IO a -> IO (Either HttpException a) +-- handleEx = try + +-- logResponse :: (Show a) => Either HttpException a -> IO () +-- logResponse = +-- either +-- ( \e -> do +-- T.putStrLn "!!!!!!!!!! REQUEST FAILED !!!!!!!!!!!" +-- T.putStrLn $ txt e +-- ) +-- ( \r -> do +-- T.putStrLn "!!!!!!!!!! REQUEST SUCCEEDED !!!!!!!!!!!" +-- T.putStrLn $ txt r +-- ) + +-------------------------------------------------------------------------------- \ No newline at end of file diff --git a/examples/WebDriverSpec.hs b/examples/WebDriverSpec.hs index 5663f33c..a27cf271 100644 --- a/examples/WebDriverSpec.hs +++ b/examples/WebDriverSpec.hs @@ -31,13 +31,16 @@ import Data.Aeson object, ) import Data.Aeson.KeyMap qualified as AKM -import Network.HTTP.Client qualified as NC -import Network.HTTP.Types qualified as NT import Prelude hiding (get) +-- import Network.HTTP.Client qualified as NC (CookieJar) +-- import Network.HTTP.Types qualified as NT (ResponseHeaders) + {- Pure types and functions used in Webdriver -} --- TODO: add error handler +-- TODO: add error handler / classifier +-- (Webdriver errors - library agnostic) vs HTTP errors (eg. driver not runnning - library dependent?) + data W3Spec a = Get { description :: Text, @@ -69,19 +72,14 @@ data W3SpecShowable = Request } deriving (Show) -mkShowable :: W3Spec a -> W3SpecShowable -mkShowable = \case - Get d p _ -> Request d "GET" p Nothing - Post d p b _ -> Request d "POST" p (Just b) - PostEmpty d p _ -> Request d "POST" p Nothing - Delete d p _ -> Request d "DELETE" p Nothing data HttpResponse = Response { statusCode :: Int, statusMessage :: Text, - headers :: NT.ResponseHeaders, - body :: Value, - cookies :: NC.CookieJar + body :: Value + -- not used yet may be able to remove and reduce dependencies + -- headers :: NT.ResponseHeaders, + -- cookies :: NC.CookieJar } deriving (Show) @@ -98,15 +96,6 @@ data DriverStatus | Unknown {statusCode :: Int, statusMessage :: Text} deriving (Show, Eq) -parseDriverStatus :: HttpResponse -> Maybe DriverStatus -parseDriverStatus Response {statusCode, statusMessage} = - Just $ - statusCode & \case - 200 -> Ready - 500 -> ServiceError {statusCode, statusMessage} - 501 -> Running - _ -> Unknown {statusCode, statusMessage} - -- TODO: add more selector types newtype Selector = CSS Text deriving (Show) @@ -163,23 +152,10 @@ capsToJson caps = ] -} -session :: Text -session = "session" - -session1 :: Text -> [Text] -session1 sp = [session, sp] - -sessionId1 :: SessionRef -> Text -> [Text] -sessionId1 sr sp = [session, sr.id, sp] - -window :: Text -window = "window" - -window1 :: SessionRef -> Text -> [Text] -window1 sr sp = [session, sr.id, window, sp] -element1 :: SessionRef -> ElementRef -> Text -> [Text] -element1 sr er sp = [session, sr.id, "element", er.id, sp] +-- ###################################################################### +-- ########################### WebDriver API ############################ +-- ###################################################################### -- https://www.w3.org/TR/2024/WD-webdriver2-20240723/ {- @@ -344,4 +320,38 @@ parseElementRef r = -- very strange choice for prop name - in response and sane as webdriver-w3c >>= lookup "element-6066-11e4-a52e-4f735466cecf" >>= asText - ) \ No newline at end of file + ) + +session :: Text +session = "session" + +session1 :: Text -> [Text] +session1 sp = [session, sp] + +sessionId1 :: SessionRef -> Text -> [Text] +sessionId1 sr sp = [session, sr.id, sp] + +window :: Text +window = "window" + +window1 :: SessionRef -> Text -> [Text] +window1 sr sp = [session, sr.id, window, sp] + +element1 :: SessionRef -> ElementRef -> Text -> [Text] +element1 sr er sp = [session, sr.id, "element", er.id, sp] + +mkShowable :: W3Spec a -> W3SpecShowable +mkShowable = \case + Get d p _ -> Request d "GET" p Nothing + Post d p b _ -> Request d "POST" p (Just b) + PostEmpty d p _ -> Request d "POST" p Nothing + Delete d p _ -> Request d "DELETE" p Nothing + +parseDriverStatus :: HttpResponse -> Maybe DriverStatus +parseDriverStatus Response {statusCode, statusMessage} = + Just $ + statusCode & \case + 200 -> Ready + 500 -> ServiceError {statusCode, statusMessage} + 501 -> Running + _ -> Unknown {statusCode, statusMessage} \ No newline at end of file diff --git a/package.yaml b/package.yaml index 9bb85106..853baf17 100644 --- a/package.yaml +++ b/package.yaml @@ -115,8 +115,8 @@ dependencies: - unliftio - yaml # used to talk to ghecko driver - - http-client - - http-types + # - http-client + # - http-types - req # webdriver used in TestdemoSelenium - webdriver-w3c diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 82031147..5d8b6adb 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: be68a122f25a6347efe5553ecd39f294f56632f30e3c7608fbdf389abda8053d +-- hash: 6fd4ef585454e85aa2ab5d4c7fe48c315eb256929b9fb58776234d11098d5866 name: pyrethrum version: 0.1.0.0 @@ -202,8 +202,6 @@ library , extra , fmt , hashable - , http-client - , http-types , mtl , path , path-io diff --git a/src/Prepare.hs b/src/Prepare.hs index 3a093a86..f91c9f97 100644 --- a/src/Prepare.hs +++ b/src/Prepare.hs @@ -296,7 +296,11 @@ prepareTest mode interpreter rc path = do logTestAndAction snk i as <- runAction snk action i - let !evt = Parse path . ApStateText $ txt as + + -- TODO: RESTORE IF NEEDED + -- let !evt = Parse path . ApStateText $ txt as + let evt = Parse path . ApStateText $ txt as + flog snk evt unTry snk $ applyParser parser as applyChecks snk path i.checks ds From 46e7c79a0512a382c9d8c0b603029724777f9c8b Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 26 Sep 2024 20:39:23 +0000 Subject: [PATCH 24/43] more renaming --- examples/FileSystemDocDemo.hs | 4 ++-- examples/IOEffectDemo.hs | 4 ++-- examples/PyrethrumDemoTest.hs | 6 +++--- examples/WebDriverDemo.hs | 2 +- src/DSL/Internal/NodeLog.hs | 4 ++-- src/DSL/Logging.hs | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/examples/FileSystemDocDemo.hs b/examples/FileSystemDocDemo.hs index 365bc1b2..8bb0ef46 100644 --- a/examples/FileSystemDocDemo.hs +++ b/examples/FileSystemDocDemo.hs @@ -6,7 +6,7 @@ import DSL.FileSystemEffect findFilesWith, walkDirAccum, ) -import DSL.Internal.NodeLog (NodeLog (User), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (User), UserLog (Info)) import DSL.OutEffect (Out, Sink (Sink), out) import DSL.OutInterpreter ( runOut ) import Data.List.Extra (isInfixOf) @@ -67,7 +67,7 @@ apEventOut :: forall a es. (IOE :> es) => Eff (Out NodeLog : es) a -> Eff es a apEventOut = runOut print log :: (Out NodeLog :> es) => Text -> Eff es () -log = out . User . Log +log = out . User . Info getPaths :: (Out NodeLog :> es, FileSystem :> es) => Eff es [Path Abs File] getPaths = diff --git a/examples/IOEffectDemo.hs b/examples/IOEffectDemo.hs index f2e69432..712c27fc 100644 --- a/examples/IOEffectDemo.hs +++ b/examples/IOEffectDemo.hs @@ -119,10 +119,10 @@ ioRun ap = ap & runEff logShow :: (Out NodeLog :> es, Show a) => a -> Eff es () -logShow = out . User . Log . txt +logShow = out . User . Info . txt log :: (Out NodeLog :> es) => Text -> Eff es () -log = out . User . Log +log = out . User . Info -- $ > ioRun effDemo effDemo :: Eff '[FileSystem, Out NodeLog, IOE] () diff --git a/examples/PyrethrumDemoTest.hs b/examples/PyrethrumDemoTest.hs index 3ba10d63..64e71871 100644 --- a/examples/PyrethrumDemoTest.hs +++ b/examples/PyrethrumDemoTest.hs @@ -3,7 +3,7 @@ module PyrethrumDemoTest where import Check (Checks, chk) -- TODO Base should reexport all required types from core import Core (After, Around, Before, Each, Once, ParseException, Thread) -import DSL.Internal.NodeLog (NodeLog (..), Path (..), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (..), Path (..), UserLog (Info)) import DSL.OutEffect (out) import Effectful (Eff) import PyrethrumBase ( @@ -29,10 +29,10 @@ were starting to look more complex than the original so abandonned. -} log :: (HasLog es) => Text -> Eff es () -log = out . User . Log +log = out . User . Info logShow :: (HasLog es, Show a) => a -> Eff es () -logShow = out . User . Log . txt +logShow = out . User . Info . txt {- Demonstraits using partial effect type LogEffs a = forall es. (Out NodeLog :> es) => Eff es a diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index a46ab6c4..25a7e613 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -2,7 +2,7 @@ module WebDriverDemo where import Check import Core (ParseException) -import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Log)) +import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Info)) import DSL.OutEffect (Out, out) import Effectful as EF ( Eff, diff --git a/src/DSL/Internal/NodeLog.hs b/src/DSL/Internal/NodeLog.hs index 7c6393ca..8ab6e644 100644 --- a/src/DSL/Internal/NodeLog.hs +++ b/src/DSL/Internal/NodeLog.hs @@ -81,8 +81,8 @@ data FrameworkLog data UserLog = StartFolder Text | EndFolder Text - | Log Text - | Log' + | Info Text + | Info' { message :: Text, details :: Text } diff --git a/src/DSL/Logging.hs b/src/DSL/Logging.hs index e9051887..f45c1074 100644 --- a/src/DSL/Logging.hs +++ b/src/DSL/Logging.hs @@ -17,4 +17,4 @@ logTxt :: (Out E.NodeLog :> es, Show a) => a -> Eff es () logTxt = log . txt log :: (Out E.NodeLog :> es) => Text -> Eff es () -log = out . E.User . E.Log \ No newline at end of file +log = out . E.User . E.Info \ No newline at end of file From c1826d6e2cd4ad0e6a2ffa1dd341623ba79b9a37 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 26 Sep 2024 21:43:09 +0000 Subject: [PATCH 25/43] WIP --- src/Internal/Logging.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index f8934131..a65353c8 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -41,7 +41,7 @@ runWithLogger :: forall l lx. LogControls l lx -> (LoggerSource l -> IO ()) -> I runWithLogger LogControls { sink, - aggregator, + expander, logWorker, stopWorker } @@ -59,20 +59,21 @@ runWithLogger ) where mkNewLogger :: IO (l -> IO ()) - mkNewLogger = mkLogger aggregator sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId + mkNewLogger = mkLogger expander sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId -- adds log index and thread id to loggable event and sends it to the sink mkLogger :: forall l lxp. (C.ThreadId -> Int -> l -> lxp) -> (lxp -> IO ()) -> IORef Int -> ThreadId -> l -> IO () -mkLogger aggregator sink idxRef thrdId logEvnt = do +mkLogger expander sink idxRef thrdId logEvnt = do + -- TODO: Add timestamp - need to change type of expander tc <- readIORef idxRef let nxt = succ tc - finally (sink $ aggregator (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt + finally (sink $ expander (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt -- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure -data LogControls l lx = LogControls - { aggregator :: C.ThreadId -> Int -> l -> lx, - sink :: lx -> IO (), +data LogControls log expandedLog = LogControls + { expander :: C.ThreadId -> Int -> log -> expandedLog, + sink :: expandedLog -> IO (), logWorker :: IO (), stopWorker :: IO () } @@ -86,7 +87,7 @@ q2List qu = reverse <$> recurse [] qu >>= maybe (pure l) (\e -> recurse (e : l) q) testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) -testLogControls' aggregator wantConsole = do +testLogControls' expander wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -107,7 +108,7 @@ testLogControls' aggregator wantConsole = do writeTChan chn $ Just eventLog writeTQueue log eventLog - pure (LogControls {..}, q2List log) + pure (LogControls {logWorker, stopWorker, sink, expander}, q2List log) {- Logging functions specialised to Event type -} From aa7fb0523b725958791dcdf03146ec1cfcba4c0a Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 26 Sep 2024 23:13:19 +0000 Subject: [PATCH 26/43] WIP - renaming --- examples/DocumenterDemo.hs | 2 +- examples/PyrethrumBase.hs | 13 ++++++--- examples/WebDriverDemo.hs | 2 +- src/Internal/LogQueries.hs | 34 +++++++++++----------- src/Internal/Logging.hs | 56 +++++++++++++++++++----------------- src/Internal/SuiteRuntime.hs | 30 ++++++++++--------- test/SuiteRuntimeTestBase.hs | 32 ++++++++++----------- 7 files changed, 88 insertions(+), 81 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 262dcd5f..8d1f31f2 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -46,7 +46,7 @@ import WebDriverSpec (DriverStatus (..), Selector (CSS)) runDemo :: SuiteRunner -> Suite -> IO () runDemo runner suite = do - (logControls, _logList) <- L.testLogControls True + (logControls, _logList) <- L.testLogActions True runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls -- putStrLn "########## Log ##########" diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 4e47f809..89dc1d8a 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -63,7 +63,12 @@ type ApEffs = '[FileSystem, WebUI, Out NodeLog, IOE] -- type ApConstraints es = (FileSystem :> es, Out NodeLog :> es, Error FSException :> es, IOE :> es) -- type AppEffs a = forall es. (FileSystem :> es, Out NodeLog :> es, Error FSException :> es, IOE :> es) => Eff es a -type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () +type SuiteRunner = Suite + -> Filters RunConfig FixtureConfig + -> RunConfig + -> ThreadCount + -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) + -> IO () ioInterpreter :: AE.LogSink -> Action a -> IO a ioInterpreter sink ap = @@ -74,7 +79,7 @@ ioInterpreter sink ap = & runEff --- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () +-- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.MkLogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () -- docRunner suite filters runConfig threadCount logControls = -- execute threadCount logControls $ -- C.MkSuiteExeParams @@ -84,7 +89,7 @@ ioInterpreter sink ap = -- runConfig -- } -docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () +docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () docRunner includeSteps includeChecks suite filters runConfig threadCount logControls = prepared & either print @@ -101,7 +106,7 @@ docRunner includeSteps includeChecks suite filters runConfig threadCount logCont -ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> IO () +ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () ioRunner suite filters runConfig threadCount logControls = execute threadCount logControls $ C.MkSuiteExeParams diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index 25a7e613..4840c91e 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -33,7 +33,7 @@ suite = runDemo :: SuiteRunner -> Suite -> IO () runDemo runner suite' = do - (logControls, _logLst) <- L.testLogControls True + (logControls, _logLst) <- L.testLogActions True runner suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls -- start geckodriver first: geckodriver & diff --git a/src/Internal/LogQueries.hs b/src/Internal/LogQueries.hs index defd0778..4b746ac7 100644 --- a/src/Internal/LogQueries.hs +++ b/src/Internal/LogQueries.hs @@ -19,16 +19,16 @@ evtTypeToFrequency = \case -- an individual test is always run once Test -> Once -isSuiteEventFailureWith :: (NodeType -> Bool) -> Log l a -> Bool +isSuiteEventFailureWith :: (NodeType -> Bool) -> LogOLD l a -> Bool isSuiteEventFailureWith evntPredicate l = evnt l & \case ParentFailure {nodeType = s} -> evntPredicate s _ -> False -isOnceHookParentFailure :: Log l a -> Bool +isOnceHookParentFailure :: LogOLD l a -> Bool isOnceHookParentFailure = isSuiteEventFailureWith onceHook -isHookParentFailure :: Log l a -> Bool +isHookParentFailure :: LogOLD l a -> Bool isHookParentFailure = isSuiteEventFailureWith isHook isTest :: NodeType -> Bool @@ -36,15 +36,15 @@ isTest = \case Test {} -> True _ -> False -isTestParentFailure :: Log l a -> Bool +isTestParentFailure :: LogOLD l a -> Bool isTestParentFailure l = evnt l & \case ParentFailure {nodeType = s} -> isTest s _ -> False -isTestLogItem :: Log l a -> Bool +isTestLogItem :: LogOLD l a -> Bool isTestLogItem li = (isTest <$> getSuiteEvent li) == Just True -isTestEventOrTestParentFailure :: Log l a -> Bool +isTestEventOrTestParentFailure :: LogOLD l a -> Bool isTestEventOrTestParentFailure te = isTestParentFailure te || isTestLogItem te isHook :: NodeType -> Bool @@ -66,7 +66,7 @@ threadHook = hookWithHz Thread onceSuiteEvent :: NodeType -> Bool onceSuiteEvent = (== Once) . evtTypeToFrequency -isChildless :: Log l a -> Bool +isChildless :: LogOLD l a -> Bool isChildless = threadEventToBool ( \case @@ -77,10 +77,10 @@ isChildless = suitEvntToBool :: (NodeType -> Bool) -> Maybe NodeType -> Bool suitEvntToBool = maybe False -threadEventToBool :: (NodeType -> Bool) -> Log l a -> Bool +threadEventToBool :: (NodeType -> Bool) -> LogOLD l a -> Bool threadEventToBool prd = suitEvntToBool prd . getSuiteEvent -startEndNodeMatch :: (NodeType -> Bool) -> Log l a -> Bool +startEndNodeMatch :: (NodeType -> Bool) -> LogOLD l a -> Bool startEndNodeMatch p l = evnt l & \case StartExecution {} -> False Failure {} -> False @@ -93,19 +93,17 @@ startEndNodeMatch p l = evnt l & \case End {nodeType} -> p nodeType - - -isStart :: Log a b -> Bool +isStart :: LogOLD a b -> Bool isStart l = evnt l & \case Start {} -> True _ -> False -isEnd :: Log a b -> Bool +isEnd :: LogOLD a b -> Bool isEnd l = evnt l & \case End {} -> True _ -> False -suiteEventOrParentFailureSuiteEvent :: Log a b -> Maybe NodeType +suiteEventOrParentFailureSuiteEvent :: LogOLD a b -> Maybe NodeType suiteEventOrParentFailureSuiteEvent l = evnt l & \case FilterLog {} -> Nothing @@ -118,7 +116,7 @@ suiteEventOrParentFailureSuiteEvent l = NodeLog {} -> Nothing EndExecution {} -> Nothing -getSuiteEvent :: Log a b -> Maybe NodeType +getSuiteEvent :: LogOLD a b -> Maybe NodeType getSuiteEvent l = evnt l & \case FilterLog {} -> Nothing SuiteInitFailure {} -> Nothing @@ -130,13 +128,13 @@ getSuiteEvent l = evnt l & \case NodeLog {} -> Nothing EndExecution {} -> Nothing -getHookInfo :: Log a b -> Maybe (Hz, HookPos) +getHookInfo :: LogOLD a b -> Maybe (Hz, HookPos) getHookInfo t = getSuiteEvent t >>= \case Hook hz pos -> Just (hz, pos) Test {} -> Nothing -startOrParentFailure :: Log l a -> Bool +startOrParentFailure :: LogOLD l a -> Bool startOrParentFailure l = evnt l & \case FilterLog {} -> False SuiteInitFailure {} -> False @@ -150,7 +148,7 @@ startOrParentFailure l = evnt l & \case Start {} -> True End {} -> False -startSuiteEventLoc :: Log l a -> Maybe l +startSuiteEventLoc :: LogOLD l a -> Maybe l startSuiteEventLoc l = evnt l & \case FilterLog {} -> Nothing SuiteInitFailure {} -> Nothing diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index a65353c8..8d7a7635 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -24,31 +24,35 @@ import Prelude hiding (atomically, lines) {- Fully polymorphic base logging functions -} +type LogOLD l a = FullLog LineInfo (Event l a) -data BaseLog lc evt = MkLog - { logContext :: lc, +evnt :: FullLog LineInfo (Event l a) -> Event l a +evnt = (.event) + +data FullLog li evt = MkLog + { lineInfo :: li, event :: evt } deriving (Show) deriving (Generic, NFData) -data LoggerSource l = MkLoggerSource +data Loggers l = MkLoggers { rootLogger :: l -> IO (), newLogger :: IO (l -> IO ()) } -runWithLogger :: forall l lx. LogControls l lx -> (LoggerSource l -> IO ()) -> IO () +runWithLogger :: forall l lx. LogActions l lx -> (Loggers l -> IO ()) -> IO () runWithLogger - LogControls + MkLogActions { sink, - expander, + expandLog, logWorker, stopWorker } action = do rootLogger <- mkNewLogger - let loggerSource = MkLoggerSource rootLogger mkNewLogger + let loggerSource = MkLoggers rootLogger mkNewLogger -- logWorker and execution run concurrently -- logworker serialises the log events emitted by the execution concurrently_ @@ -59,7 +63,7 @@ runWithLogger ) where mkNewLogger :: IO (l -> IO ()) - mkNewLogger = mkLogger expander sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId + mkNewLogger = mkLogger expandLog sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId -- adds log index and thread id to loggable event and sends it to the sink mkLogger :: forall l lxp. (C.ThreadId -> Int -> l -> lxp) -> (lxp -> IO ()) -> IORef Int -> ThreadId -> l -> IO () @@ -71,9 +75,14 @@ mkLogger expander sink idxRef thrdId logEvnt = do -- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure -data LogControls log expandedLog = LogControls - { expander :: C.ThreadId -> Int -> log -> expandedLog, + + + +data LogActions log expandedLog = MkLogActions + { -- adds line info to the log TODO: Add timestamp (and agent?) + expandLog :: C.ThreadId -> Int -> log -> expandedLog, sink :: expandedLog -> IO (), + -- worker that serializes log events logWorker :: IO (), stopWorker :: IO () } @@ -86,8 +95,8 @@ q2List qu = reverse <$> recurse [] qu tryReadTQueue q >>= maybe (pure l) (\e -> recurse (e : l) q) -testLogControls' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogControls l lx, STM [lx]) -testLogControls' expander wantConsole = do +testLogActions' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogActions l lx, STM [lx]) +testLogActions' expandLog wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -108,19 +117,12 @@ testLogControls' expander wantConsole = do writeTChan chn $ Just eventLog writeTQueue log eventLog - pure (LogControls {logWorker, stopWorker, sink, expander}, q2List log) + pure (MkLogActions {logWorker, stopWorker, sink, expandLog}, q2List log) {- Logging functions specialised to Event type -} -type Log l a = BaseLog LogContext (Event l a) - -ctx :: Log l a -> LogContext -ctx = (.logContext) - -evnt :: Log l a -> Event l a -evnt = (.event) -data LogContext = MkLogContext +data LineInfo = MkLineInfo { threadId :: C.ThreadId, idx :: Int } @@ -188,7 +190,7 @@ data FailPoint = FailPoint mkFailure :: l -> NodeType -> SomeException -> Event l a mkFailure loc nodeType exception = Failure {exception = C.exceptionTxt exception, ..} -data Event loc evnt +data Event loc nodeLog = FilterLog { filterResuts :: [FilterResult Text] } @@ -217,19 +219,19 @@ data Event loc evnt failSuiteEvent :: NodeType } | NodeLog - { event :: evnt + { nodeLog :: nodeLog } | EndExecution deriving (Show, Generic, NFData) -testLogControls :: forall l a. (Show a, Show l) => Bool -> IO (LogControls (Event l a) (Log l a), STM [Log l a]) -testLogControls = testLogControls' expandEvent +testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Event l a) (FullLog LineInfo (Event l a)), STM [FullLog LineInfo (Event l a)]) +testLogActions = testLogActions' expandEvent -- -- NodeLog (a) a loggable event generated from within a node -- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors -- -- Log a - adds thread id and index to EngineEvent -expandEvent :: C.ThreadId -> Int -> Event l a -> Log l a -expandEvent threadId idx = MkLog (MkLogContext threadId idx) +expandEvent :: C.ThreadId -> Int -> Event l a -> FullLog LineInfo (Event l a) +expandEvent threadId idx = MkLog (MkLineInfo threadId idx) $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 1e7129be..4eb79546 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -2,7 +2,7 @@ module Internal.SuiteRuntime where import Core qualified as C import CoreUtils (Hz (..)) -import DSL.Internal.NodeLog qualified as AE +import DSL.Internal.NodeLog qualified as N import Internal.Logging (HookPos (..), NodeType (..)) import Internal.Logging qualified as L import Internal.SuiteFiltering (FilteredSuite (..)) @@ -34,18 +34,20 @@ todo :: define defect properties with sum type type and typeclass which returns newtype ThreadCount = ThreadCount {maxThreads :: Int} deriving (Show) +type Log = L.FullLog L.LineInfo (L.Event L.ExePath N.NodeLog) + -- executes prenodes directly without any tree shaking, -- filtering or validation used in testing -executeWithoutValidation :: ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> [P.PreNode IO ()] -> IO () +executeWithoutValidation :: ThreadCount -> L.LogActions (L.Event L.ExePath N.NodeLog) Log -> [P.PreNode IO ()] -> IO () executeWithoutValidation tc lc pn = L.runWithLogger lc (\l -> executeNodeList tc l pn) -execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogControls (L.Event L.ExePath AE.NodeLog) (L.Log L.ExePath AE.NodeLog) -> C.SuiteExeParams m rc fc -> IO () +execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogActions (L.Event L.ExePath N.NodeLog) Log -> C.SuiteExeParams m rc fc -> IO () execute tc lc prms = L.runWithLogger lc execute' where - execute' :: L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> IO () - execute' l@L.MkLoggerSource{rootLogger} = + execute' :: L.Loggers (L.Event L.ExePath N.NodeLog) -> IO () + execute' l@L.MkLoggers{rootLogger} = do P.prepare prms & either @@ -56,14 +58,14 @@ execute tc lc prms = executeNodeList tc l validated.suite ) -executeNodeList :: ThreadCount -> L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> [P.PreNode IO ()] -> IO () +executeNodeList :: ThreadCount -> L.Loggers (L.Event L.ExePath N.NodeLog) -> [P.PreNode IO ()] -> IO () executeNodeList tc lgr nodeList = do xtree <- mkXTree (L.ExePath []) nodeList executeNodes lgr xtree tc -executeNodes :: L.LoggerSource (L.Event L.ExePath AE.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () -executeNodes L.MkLoggerSource {rootLogger, newLogger} nodes tc = +executeNodes :: L.Loggers (L.Event L.ExePath N.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () +executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = do finally ( rootLogger L.StartExecution @@ -356,9 +358,9 @@ data ExeIn oi ti tsti = ExeIn tstIn :: tsti } -type Logger = L.Event L.ExePath AE.NodeLog -> IO () +type SuiteLogger = L.Event L.ExePath N.NodeLog -> IO () -logAbandonned :: Logger -> L.ExePath -> NodeType -> L.FailPoint -> IO () +logAbandonned :: SuiteLogger -> L.ExePath -> NodeType -> L.FailPoint -> IO () logAbandonned lgr p e a = lgr $ L.ParentFailure @@ -377,7 +379,7 @@ ioRight = pure . Right noImpPropertyError :: any noImpPropertyError = error "property tests not implemented" -logReturnFailure :: Logger -> L.ExePath -> NodeType -> SomeException -> IO (Either L.FailPoint b) +logReturnFailure :: SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO (Either L.FailPoint b) logReturnFailure lgr p et e = lgr (L.mkFailure p et e) >> ioLeft (L.FailPoint p et) @@ -573,7 +575,7 @@ canLockTeardown s qs = runNode :: forall hi. - Logger -> + SuiteLogger -> NodeIn hi -> ExeTree hi -> IO QElementRun @@ -640,7 +642,7 @@ runNode lgr hi xt = pure $ QElementRun True mkTestPath :: forall a. P.Test IO a -> L.ExePath - mkTestPath P.MkTest {id, title = ttl} = L.ExePath $ AE.TestPath {id, title = ttl} : coerce xt.path {- fixture path -} + mkTestPath P.MkTest {id, title = ttl} = L.ExePath $ N.TestPath {id, title = ttl} : coerce xt.path {- fixture path -} abandonSubs :: forall a. L.FailPoint -> ChildQ (ExeTree a) -> IO QElementRun abandonSubs fp = runSubNodes (Abandon fp) @@ -1107,7 +1109,7 @@ tryLock canLock hs cq lockedStatus = tryLockIO :: (s -> CanRun -> Bool) -> TVar s -> ChildQ a -> s -> IO Bool tryLockIO canLock hs cq lockedStatus = atomically $ tryLock canLock hs cq lockedStatus -logRun :: Logger -> L.ExePath -> NodeType -> IO b -> IO (Either L.FailPoint b) +logRun :: SuiteLogger -> L.ExePath -> NodeType -> IO b -> IO (Either L.FailPoint b) logRun lgr path evt action = do lgr $ L.Start evt path finally diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index aea1baf0..81ce5049 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -39,13 +39,13 @@ import Internal.Logging as L ( Event (..), ExePath (..), HookPos (..), - Log (), + LogOLD (), NodeType (..), parentPath, - testLogControls, + testLogActions, topPath, - BaseLog (..), - LogContext (..) + FullLog (..), + LineInfo(..) ) import Internal.SuiteRuntime (ThreadCount (..), executeWithoutValidation) import Prepare qualified as P @@ -126,10 +126,10 @@ https://hackage.haskell.org/package/Agda-2.6.4.3/Agda-2.6.4.3.tar.gz $ cabal install -f +optimise-heavily -f +enable-cluster-counting -} -type LogItem = Log ExePath AE.NodeLog +type LogItem = LogOLD ExePath AE.NodeLog getThreadId :: LogItem -> ThreadId -getThreadId (MkLog (MkLogContext {threadId}) _) = threadId +getThreadId (MkLog (MkLineInfo{threadId}) _) = threadId logItemtoBool :: (NodeType -> Bool) -> LogItem -> Bool logItemtoBool = threadEventToBool @@ -395,7 +395,7 @@ isFailChildEventOf :: LogItem -> LogItem -> Bool isFailChildEventOf c p = (cIsSubpathOfp || samePath && pIsSetupFailure && cIsTeardown) && (sameThread || pIsOnceHook) where - sameThread = p.logContext.threadId == c.logContext.threadId + sameThread = p.lineInfo.threadId == c.lineInfo.threadId hasHookPos hp = \case Hook _ hp' -> hp == hp' _ -> False @@ -739,10 +739,10 @@ nxtHookLog = find (\l -> startEndNodeMatch isHook l || isHookParentFailure l) threadVisible :: Bool -> ThreadId -> [LogItem] -> [LogItem] threadVisible onceHookInclude tid = - filter (\l -> tid == l.logContext.threadId || onceHookInclude && (startEndNodeMatch onceHook l || isOnceHookParentFailure l)) + filter (\l -> tid == l.lineInfo.threadId || onceHookInclude && (startEndNodeMatch onceHook l || isOnceHookParentFailure l)) threadIds :: [LogItem] -> [ThreadId] -threadIds = PE.nub . fmap (.logContext.threadId) +threadIds = PE.nub . fmap (.lineInfo.threadId) threadedLogs :: Bool -> [LogItem] -> [[LogItem]] threadedLogs onceHookInclude l = @@ -751,7 +751,7 @@ threadedLogs onceHookInclude l = shouldOccurOnce :: LogItem -> Bool shouldOccurOnce = startEndNodeMatch onceSuiteEvent -chkStartEndExecution :: [Log ExePath AE.NodeLog] -> IO () +chkStartEndExecution :: [LogOLD ExePath AE.NodeLog] -> IO () chkStartEndExecution evts = (,) <$> PE.head evts @@ -784,7 +784,7 @@ chkThreadLogsInOrder :: [LogItem] -> IO () chkThreadLogsInOrder ls = do chk' "Nothing found in heads - groupOn error this should not happen" (all isJust heads) - traverse_ (chkEq' "first index of thread should be 0" 0 . (.logContext.idx)) $ catMaybes heads + traverse_ (chkEq' "first index of thread should be 0" 0 . (.lineInfo.idx)) $ catMaybes heads traverse_ chkIds threads where threads = groupOn' getThreadId ls @@ -794,8 +794,8 @@ chkThreadLogsInOrder ls = for_ (zip ls' $ drop 1 ls') ( \(l1, l2) -> - let idx1 = l1.logContext.idx - idx2 = l2.logContext.idx + let idx1 = l1.lineInfo.idx + idx2 = l2.lineInfo.idx in chkEqfmt' (succ idx1) idx2 $ "event idx not consecutive\n" <> toS (ppShow l1) @@ -856,7 +856,7 @@ test = Spec 0 data ExeResult = ExeResult { expandedTemplate :: [T.Template], - log :: [Log ExePath AE.NodeLog] + log :: [LogOLD ExePath AE.NodeLog] } runTest :: Int -> ThreadCount -> [Template] -> IO () @@ -886,10 +886,10 @@ execute wantLog baseRandomSeed threadLimit templates = do lg <- exeTemplate wantLog baseRandomSeed threadLimit fullTs pure $ ExeResult fullTs lg -exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [Log ExePath AE.NodeLog] +exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [LogOLD ExePath AE.NodeLog] exeTemplate wantLog baseRandomSeed maxThreads templates = do let wantLog' = wantLog == Log - (lc, logLst) <- testLogControls wantLog' + (lc, logLst) <- testLogActions wantLog' when (wantLog' || wantLog == LogTemplate) $ do putStrLn "#### Template ####" pPrint templates From 4c11e68b45c15ad6b55d836d3545b26bf0256904 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 28 Sep 2024 01:18:52 +0000 Subject: [PATCH 27/43] wip add mkLogSink --- src/Internal/Logging.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 8d7a7635..b9e963ea 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -87,6 +87,9 @@ data LogActions log expandedLog = MkLogActions stopWorker :: IO () } +mkLogSink :: forall lg expLg. (lg -> IO expLg) -> (expLg -> IO ()) -> lg -> IO () +mkLogSink expansion expandedSink lg = expansion lg >>= expandedSink + q2List :: TQueue a -> STM [a] q2List qu = reverse <$> recurse [] qu where From bbf1cb342ee35003eebf71a71bc059713c481ae6 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 28 Sep 2024 01:25:51 +0000 Subject: [PATCH 28/43] WIP --- src/Internal/Logging.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index b9e963ea..69e468cd 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -88,7 +88,10 @@ data LogActions log expandedLog = MkLogActions } mkLogSink :: forall lg expLg. (lg -> IO expLg) -> (expLg -> IO ()) -> lg -> IO () -mkLogSink expansion expandedSink lg = expansion lg >>= expandedSink +mkLogSink + expander -- transform an input log into an output log in IO (so can read time etc) + expandedSink -- somwhere in io to push the expanded log (eg.stdout or a file) + lg = expander lg >>= expandedSink q2List :: TQueue a -> STM [a] q2List qu = reverse <$> recurse [] qu From 5dd50562f655cb78941ff78c64d5dd297f05cd29 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 28 Sep 2024 12:11:45 +0000 Subject: [PATCH 29/43] bit of renaming --- examples/PyrethrumBase.hs | 8 ++++---- src/Internal/LogQueries.hs | 38 ++++++++++++++++++++---------------- src/Internal/Logging.hs | 17 +++++++--------- src/Internal/SuiteRuntime.hs | 14 ++++++------- test/SuiteRuntimeTestBase.hs | 12 ++++++------ 5 files changed, 45 insertions(+), 44 deletions(-) diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 89dc1d8a..49b1161f 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -67,7 +67,7 @@ type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount - -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) + -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () ioInterpreter :: AE.LogSink -> Action a -> IO a @@ -79,7 +79,7 @@ ioInterpreter sink ap = & runEff --- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.MkLogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () +-- docRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.MkLogActions (L.Event L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () -- docRunner suite filters runConfig threadCount logControls = -- execute threadCount logControls $ -- C.MkSuiteExeParams @@ -89,7 +89,7 @@ ioInterpreter sink ap = -- runConfig -- } -docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () +docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () docRunner includeSteps includeChecks suite filters runConfig threadCount logControls = prepared & either print @@ -106,7 +106,7 @@ docRunner includeSteps includeChecks suite filters runConfig threadCount logCont -ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Event L.ExePath AE.NodeLog) (L.LogOLD L.ExePath AE.NodeLog) -> IO () +ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () ioRunner suite filters runConfig threadCount logControls = execute threadCount logControls $ C.MkSuiteExeParams diff --git a/src/Internal/LogQueries.hs b/src/Internal/LogQueries.hs index 4b746ac7..b084adcd 100644 --- a/src/Internal/LogQueries.hs +++ b/src/Internal/LogQueries.hs @@ -1,7 +1,11 @@ module Internal.LogQueries where import CoreUtils -import Internal.Logging +import Internal.Logging( NodeType(..), + HookPos(..), + Log(..), + FLog, + evnt ) isSetup :: NodeType -> Bool isSetup = \case @@ -19,16 +23,16 @@ evtTypeToFrequency = \case -- an individual test is always run once Test -> Once -isSuiteEventFailureWith :: (NodeType -> Bool) -> LogOLD l a -> Bool +isSuiteEventFailureWith :: (NodeType -> Bool) -> FLog l a -> Bool isSuiteEventFailureWith evntPredicate l = evnt l & \case ParentFailure {nodeType = s} -> evntPredicate s _ -> False -isOnceHookParentFailure :: LogOLD l a -> Bool +isOnceHookParentFailure :: FLog l a -> Bool isOnceHookParentFailure = isSuiteEventFailureWith onceHook -isHookParentFailure :: LogOLD l a -> Bool +isHookParentFailure :: FLog l a -> Bool isHookParentFailure = isSuiteEventFailureWith isHook isTest :: NodeType -> Bool @@ -36,15 +40,15 @@ isTest = \case Test {} -> True _ -> False -isTestParentFailure :: LogOLD l a -> Bool +isTestParentFailure :: FLog l a -> Bool isTestParentFailure l = evnt l & \case ParentFailure {nodeType = s} -> isTest s _ -> False -isTestLogItem :: LogOLD l a -> Bool +isTestLogItem :: FLog l a -> Bool isTestLogItem li = (isTest <$> getSuiteEvent li) == Just True -isTestEventOrTestParentFailure :: LogOLD l a -> Bool +isTestEventOrTestParentFailure :: FLog l a -> Bool isTestEventOrTestParentFailure te = isTestParentFailure te || isTestLogItem te isHook :: NodeType -> Bool @@ -66,7 +70,7 @@ threadHook = hookWithHz Thread onceSuiteEvent :: NodeType -> Bool onceSuiteEvent = (== Once) . evtTypeToFrequency -isChildless :: LogOLD l a -> Bool +isChildless :: FLog l a -> Bool isChildless = threadEventToBool ( \case @@ -77,10 +81,10 @@ isChildless = suitEvntToBool :: (NodeType -> Bool) -> Maybe NodeType -> Bool suitEvntToBool = maybe False -threadEventToBool :: (NodeType -> Bool) -> LogOLD l a -> Bool +threadEventToBool :: (NodeType -> Bool) -> FLog l a -> Bool threadEventToBool prd = suitEvntToBool prd . getSuiteEvent -startEndNodeMatch :: (NodeType -> Bool) -> LogOLD l a -> Bool +startEndNodeMatch :: (NodeType -> Bool) -> FLog l a -> Bool startEndNodeMatch p l = evnt l & \case StartExecution {} -> False Failure {} -> False @@ -93,17 +97,17 @@ startEndNodeMatch p l = evnt l & \case End {nodeType} -> p nodeType -isStart :: LogOLD a b -> Bool +isStart :: FLog a b -> Bool isStart l = evnt l & \case Start {} -> True _ -> False -isEnd :: LogOLD a b -> Bool +isEnd :: FLog a b -> Bool isEnd l = evnt l & \case End {} -> True _ -> False -suiteEventOrParentFailureSuiteEvent :: LogOLD a b -> Maybe NodeType +suiteEventOrParentFailureSuiteEvent :: FLog a b -> Maybe NodeType suiteEventOrParentFailureSuiteEvent l = evnt l & \case FilterLog {} -> Nothing @@ -116,7 +120,7 @@ suiteEventOrParentFailureSuiteEvent l = NodeLog {} -> Nothing EndExecution {} -> Nothing -getSuiteEvent :: LogOLD a b -> Maybe NodeType +getSuiteEvent :: FLog a b -> Maybe NodeType getSuiteEvent l = evnt l & \case FilterLog {} -> Nothing SuiteInitFailure {} -> Nothing @@ -128,13 +132,13 @@ getSuiteEvent l = evnt l & \case NodeLog {} -> Nothing EndExecution {} -> Nothing -getHookInfo :: LogOLD a b -> Maybe (Hz, HookPos) +getHookInfo :: FLog a b -> Maybe (Hz, HookPos) getHookInfo t = getSuiteEvent t >>= \case Hook hz pos -> Just (hz, pos) Test {} -> Nothing -startOrParentFailure :: LogOLD l a -> Bool +startOrParentFailure :: FLog l a -> Bool startOrParentFailure l = evnt l & \case FilterLog {} -> False SuiteInitFailure {} -> False @@ -148,7 +152,7 @@ startOrParentFailure l = evnt l & \case Start {} -> True End {} -> False -startSuiteEventLoc :: LogOLD l a -> Maybe l +startSuiteEventLoc :: FLog l a -> Maybe l startSuiteEventLoc l = evnt l & \case FilterLog {} -> Nothing SuiteInitFailure {} -> Nothing diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 69e468cd..ee8e50c6 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -22,11 +22,11 @@ import UnliftIO.Concurrent (ThreadId) import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) import Prelude hiding (atomically, lines) +type FLog l a = FullLog LineInfo (Log l a) {- Fully polymorphic base logging functions -} -type LogOLD l a = FullLog LineInfo (Event l a) -evnt :: FullLog LineInfo (Event l a) -> Event l a +evnt :: FullLog LineInfo (Log l a) -> Log l a evnt = (.event) data FullLog li evt = MkLog @@ -75,9 +75,6 @@ mkLogger expander sink idxRef thrdId logEvnt = do -- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure - - - data LogActions log expandedLog = MkLogActions { -- adds line info to the log TODO: Add timestamp (and agent?) expandLog :: C.ThreadId -> Int -> log -> expandedLog, @@ -193,10 +190,10 @@ data FailPoint = FailPoint } deriving (Show) -mkFailure :: l -> NodeType -> SomeException -> Event l a +mkFailure :: l -> NodeType -> SomeException -> Log l a mkFailure loc nodeType exception = Failure {exception = C.exceptionTxt exception, ..} -data Event loc nodeLog +data Log loc nodeLog = FilterLog { filterResuts :: [FilterResult Text] } @@ -230,18 +227,18 @@ data Event loc nodeLog | EndExecution deriving (Show, Generic, NFData) -testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Event l a) (FullLog LineInfo (Event l a)), STM [FullLog LineInfo (Event l a)]) +testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Log l a) (FullLog LineInfo (Log l a)), STM [FullLog LineInfo (Log l a)]) testLogActions = testLogActions' expandEvent -- -- NodeLog (a) a loggable event generated from within a node -- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors -- -- Log a - adds thread id and index to EngineEvent -expandEvent :: C.ThreadId -> Int -> Event l a -> FullLog LineInfo (Event l a) +expandEvent :: C.ThreadId -> Int -> Log l a -> FullLog LineInfo (Log l a) expandEvent threadId idx = MkLog (MkLineInfo threadId idx) $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) $(deriveJSON defaultOptions ''NodeType) -$(deriveToJSON defaultOptions ''Event) +$(deriveToJSON defaultOptions ''Log) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 4eb79546..901a5977 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -34,19 +34,19 @@ todo :: define defect properties with sum type type and typeclass which returns newtype ThreadCount = ThreadCount {maxThreads :: Int} deriving (Show) -type Log = L.FullLog L.LineInfo (L.Event L.ExePath N.NodeLog) +type Log = L.FullLog L.LineInfo (L.Log L.ExePath N.NodeLog) -- executes prenodes directly without any tree shaking, -- filtering or validation used in testing -executeWithoutValidation :: ThreadCount -> L.LogActions (L.Event L.ExePath N.NodeLog) Log -> [P.PreNode IO ()] -> IO () +executeWithoutValidation :: ThreadCount -> L.LogActions (L.Log L.ExePath N.NodeLog) Log -> [P.PreNode IO ()] -> IO () executeWithoutValidation tc lc pn = L.runWithLogger lc (\l -> executeNodeList tc l pn) -execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogActions (L.Event L.ExePath N.NodeLog) Log -> C.SuiteExeParams m rc fc -> IO () +execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogActions (L.Log L.ExePath N.NodeLog) Log -> C.SuiteExeParams m rc fc -> IO () execute tc lc prms = L.runWithLogger lc execute' where - execute' :: L.Loggers (L.Event L.ExePath N.NodeLog) -> IO () + execute' :: L.Loggers (L.Log L.ExePath N.NodeLog) -> IO () execute' l@L.MkLoggers{rootLogger} = do P.prepare prms @@ -58,13 +58,13 @@ execute tc lc prms = executeNodeList tc l validated.suite ) -executeNodeList :: ThreadCount -> L.Loggers (L.Event L.ExePath N.NodeLog) -> [P.PreNode IO ()] -> IO () +executeNodeList :: ThreadCount -> L.Loggers (L.Log L.ExePath N.NodeLog) -> [P.PreNode IO ()] -> IO () executeNodeList tc lgr nodeList = do xtree <- mkXTree (L.ExePath []) nodeList executeNodes lgr xtree tc -executeNodes :: L.Loggers (L.Event L.ExePath N.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () +executeNodes :: L.Loggers (L.Log L.ExePath N.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = do finally @@ -358,7 +358,7 @@ data ExeIn oi ti tsti = ExeIn tstIn :: tsti } -type SuiteLogger = L.Event L.ExePath N.NodeLog -> IO () +type SuiteLogger = L.Log L.ExePath N.NodeLog -> IO () logAbandonned :: SuiteLogger -> L.ExePath -> NodeType -> L.FailPoint -> IO () logAbandonned lgr p e a = diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index 81ce5049..f59412b4 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -36,10 +36,10 @@ import Internal.LogQueries threadHook, ) import Internal.Logging as L - ( Event (..), + ( Log (..), ExePath (..), HookPos (..), - LogOLD (), + FLog, NodeType (..), parentPath, testLogActions, @@ -126,7 +126,7 @@ https://hackage.haskell.org/package/Agda-2.6.4.3/Agda-2.6.4.3.tar.gz $ cabal install -f +optimise-heavily -f +enable-cluster-counting -} -type LogItem = LogOLD ExePath AE.NodeLog +type LogItem = FLog ExePath AE.NodeLog getThreadId :: LogItem -> ThreadId getThreadId (MkLog (MkLineInfo{threadId}) _) = threadId @@ -751,7 +751,7 @@ threadedLogs onceHookInclude l = shouldOccurOnce :: LogItem -> Bool shouldOccurOnce = startEndNodeMatch onceSuiteEvent -chkStartEndExecution :: [LogOLD ExePath AE.NodeLog] -> IO () +chkStartEndExecution :: [FLog ExePath AE.NodeLog] -> IO () chkStartEndExecution evts = (,) <$> PE.head evts @@ -856,7 +856,7 @@ test = Spec 0 data ExeResult = ExeResult { expandedTemplate :: [T.Template], - log :: [LogOLD ExePath AE.NodeLog] + log :: [FLog ExePath AE.NodeLog] } runTest :: Int -> ThreadCount -> [Template] -> IO () @@ -886,7 +886,7 @@ execute wantLog baseRandomSeed threadLimit templates = do lg <- exeTemplate wantLog baseRandomSeed threadLimit fullTs pure $ ExeResult fullTs lg -exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [LogOLD ExePath AE.NodeLog] +exeTemplate :: Logging -> Int -> ThreadCount -> [T.Template] -> IO [FLog ExePath AE.NodeLog] exeTemplate wantLog baseRandomSeed maxThreads templates = do let wantLog' = wantLog == Log (lc, logLst) <- testLogActions wantLog' From 80b53990217bc8240c7b4c21879e27279d91a81a Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 28 Sep 2024 22:34:15 +0000 Subject: [PATCH 30/43] more logging refactoring --- examples/PyrethrumBase.hs | 6 ++-- src/Internal/Logging.hs | 64 ++++++++++++++++-------------------- src/Internal/SuiteRuntime.hs | 20 +++++------ test/SuiteRuntimeTest.hs | 8 ++--- 4 files changed, 46 insertions(+), 52 deletions(-) diff --git a/examples/PyrethrumBase.hs b/examples/PyrethrumBase.hs index 49b1161f..11d0618f 100644 --- a/examples/PyrethrumBase.hs +++ b/examples/PyrethrumBase.hs @@ -67,7 +67,7 @@ type SuiteRunner = Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount - -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) + -> L.LogActions (L.Log L.ExePath AE.NodeLog) -> IO () ioInterpreter :: AE.LogSink -> Action a -> IO a @@ -89,7 +89,7 @@ ioInterpreter sink ap = -- runConfig -- } -docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () +docRunner :: Bool -> Bool -> Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) -> IO () docRunner includeSteps includeChecks suite filters runConfig threadCount logControls = prepared & either print @@ -106,7 +106,7 @@ docRunner includeSteps includeChecks suite filters runConfig threadCount logCont -ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) (L.FLog L.ExePath AE.NodeLog) -> IO () +ioRunner :: Suite -> Filters RunConfig FixtureConfig -> RunConfig -> ThreadCount -> L.LogActions (L.Log L.ExePath AE.NodeLog) -> IO () ioRunner suite filters runConfig threadCount logControls = execute threadCount logControls $ C.MkSuiteExeParams diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index ee8e50c6..8a3cd8f6 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -41,18 +41,17 @@ data Loggers l = MkLoggers newLogger :: IO (l -> IO ()) } -runWithLogger :: forall l lx. LogActions l lx -> (Loggers l -> IO ()) -> IO () +runWithLogger :: forall l. LogActions l -> (Loggers l -> IO ()) -> IO () runWithLogger MkLogActions - { sink, - expandLog, + { newSink, logWorker, stopWorker } action = do - rootLogger <- mkNewLogger - let loggerSource = MkLoggers rootLogger mkNewLogger + rootLogger <- newSink + let loggerSource = MkLoggers rootLogger newSink -- logWorker and execution run concurrently -- logworker serialises the log events emitted by the execution concurrently_ @@ -61,35 +60,17 @@ runWithLogger (action loggerSource) stopWorker ) - where - mkNewLogger :: IO (l -> IO ()) - mkNewLogger = mkLogger expandLog sink <$> UnliftIO.newIORef (-1) <*> P.myThreadId - --- adds log index and thread id to loggable event and sends it to the sink -mkLogger :: forall l lxp. (C.ThreadId -> Int -> l -> lxp) -> (lxp -> IO ()) -> IORef Int -> ThreadId -> l -> IO () -mkLogger expander sink idxRef thrdId logEvnt = do - -- TODO: Add timestamp - need to change type of expander - tc <- readIORef idxRef - let nxt = succ tc - finally (sink $ expander (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt -- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure -data LogActions log expandedLog = MkLogActions +data LogActions log = MkLogActions { -- adds line info to the log TODO: Add timestamp (and agent?) - expandLog :: C.ThreadId -> Int -> log -> expandedLog, - sink :: expandedLog -> IO (), + newSink :: IO (log -> IO ()), -- worker that serializes log events logWorker :: IO (), stopWorker :: IO () } -mkLogSink :: forall lg expLg. (lg -> IO expLg) -> (expLg -> IO ()) -> lg -> IO () -mkLogSink - expander -- transform an input log into an output log in IO (so can read time etc) - expandedSink -- somwhere in io to push the expanded log (eg.stdout or a file) - lg = expander lg >>= expandedSink - q2List :: TQueue a -> STM [a] q2List qu = reverse <$> recurse [] qu where @@ -98,8 +79,9 @@ q2List qu = reverse <$> recurse [] qu tryReadTQueue q >>= maybe (pure l) (\e -> recurse (e : l) q) -testLogActions' :: forall l lx. (Show lx) => (C.ThreadId -> Int -> l -> lx) -> Bool -> IO (LogActions l lx, STM [lx]) -testLogActions' expandLog wantConsole = do + +testLogActions' :: forall l lx. (Show lx) => ((lx -> IO ()) -> IO (l -> IO ())) -> Bool -> IO (LogActions l, STM [lx]) +testLogActions' mkNewSink wantConsole = do chn <- newTChanIO log <- newTQueueIO @@ -120,7 +102,10 @@ testLogActions' expandLog wantConsole = do writeTChan chn $ Just eventLog writeTQueue log eventLog - pure (MkLogActions {logWorker, stopWorker, sink, expandLog}, q2List log) + newSink :: IO (l -> IO ()) + newSink = mkNewSink sink + + pure (MkLogActions {logWorker, stopWorker, newSink}, q2List log) {- Logging functions specialised to Event type -} @@ -227,14 +212,23 @@ data Log loc nodeLog | EndExecution deriving (Show, Generic, NFData) -testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Log l a) (FullLog LineInfo (Log l a)), STM [FullLog LineInfo (Log l a)]) -testLogActions = testLogActions' expandEvent +testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Log l a), STM [FullLog LineInfo (Log l a)]) +testLogActions = testLogActions' mkLogSinkGenerator + +mkLogSinkGenerator :: forall l a. (FullLog LineInfo (Log l a) -> IO ()) -> IO (Log l a -> IO ()) +mkLogSinkGenerator fullSink = + logNext <$> UnliftIO.newIORef (-1) <*> P.myThreadId + where + addLineInfo :: C.ThreadId -> Int -> Log l a -> FullLog LineInfo (Log l a) + addLineInfo threadId idx = MkLog (MkLineInfo threadId idx) + + logNext :: IORef Int -> ThreadId -> Log l a -> IO () + logNext idxRef thrdId logEvnt = do + -- TODO: Add timestamp - need to change type of expander + tc <- readIORef idxRef + let nxt = succ tc + finally (fullSink $ addLineInfo (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt --- -- NodeLog (a) a loggable event generated from within a node --- -- EngineEvent a - marks start, end and failures in test fixtures (hooks, tests) and errors --- -- Log a - adds thread id and index to EngineEvent -expandEvent :: C.ThreadId -> Int -> Log l a -> FullLog LineInfo (Log l a) -expandEvent threadId idx = MkLog (MkLineInfo threadId idx) $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 901a5977..4134cac5 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -10,7 +10,7 @@ import Internal.SuiteValidation (SuiteValidationError (..)) import Prepare qualified as P import PyrethrumExtras (txt, (?)) import UnliftIO - ( tryAny, + ( tryAny, finally, forConcurrently_, writeTMVar, @@ -34,19 +34,19 @@ todo :: define defect properties with sum type type and typeclass which returns newtype ThreadCount = ThreadCount {maxThreads :: Int} deriving (Show) -type Log = L.FullLog L.LineInfo (L.Log L.ExePath N.NodeLog) +type Log = L.Log L.ExePath N.NodeLog -- executes prenodes directly without any tree shaking, -- filtering or validation used in testing -executeWithoutValidation :: ThreadCount -> L.LogActions (L.Log L.ExePath N.NodeLog) Log -> [P.PreNode IO ()] -> IO () +executeWithoutValidation :: ThreadCount -> L.LogActions Log -> [P.PreNode IO ()] -> IO () executeWithoutValidation tc lc pn = L.runWithLogger lc (\l -> executeNodeList tc l pn) -execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogActions (L.Log L.ExePath N.NodeLog) Log -> C.SuiteExeParams m rc fc -> IO () +execute :: (C.Config rc, C.Config fc) => ThreadCount -> L.LogActions Log -> C.SuiteExeParams m rc fc -> IO () execute tc lc prms = L.runWithLogger lc execute' where - execute' :: L.Loggers (L.Log L.ExePath N.NodeLog) -> IO () + execute' :: L.Loggers Log -> IO () execute' l@L.MkLoggers{rootLogger} = do P.prepare prms @@ -58,13 +58,13 @@ execute tc lc prms = executeNodeList tc l validated.suite ) -executeNodeList :: ThreadCount -> L.Loggers (L.Log L.ExePath N.NodeLog) -> [P.PreNode IO ()] -> IO () +executeNodeList :: ThreadCount -> L.Loggers Log -> [P.PreNode IO ()] -> IO () executeNodeList tc lgr nodeList = do xtree <- mkXTree (L.ExePath []) nodeList executeNodes lgr xtree tc -executeNodes :: L.Loggers (L.Log L.ExePath N.NodeLog) -> ChildQ (ExeTree ()) -> ThreadCount -> IO () +executeNodes :: L.Loggers Log -> ChildQ (ExeTree ()) -> ThreadCount -> IO () executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = do finally @@ -358,7 +358,7 @@ data ExeIn oi ti tsti = ExeIn tstIn :: tsti } -type SuiteLogger = L.Log L.ExePath N.NodeLog -> IO () +type SuiteLogger = Log -> IO () logAbandonned :: SuiteLogger -> L.ExePath -> NodeType -> L.FailPoint -> IO () logAbandonned lgr p e a = @@ -1113,7 +1113,7 @@ logRun :: SuiteLogger -> L.ExePath -> NodeType -> IO b -> IO (Either L.FailPoint logRun lgr path evt action = do lgr $ L.Start evt path finally - do - r <- tryAny action + do + r <- tryAny action r & either (logReturnFailure lgr path evt) (pure . Right) (lgr $ L.End evt path) diff --git a/test/SuiteRuntimeTest.hs b/test/SuiteRuntimeTest.hs index 4d2da8e8..1b982c4c 100644 --- a/test/SuiteRuntimeTest.hs +++ b/test/SuiteRuntimeTest.hs @@ -23,13 +23,13 @@ chkInitFailure expected filterResults = where actualFail = (.failure) <$> chkSuite filterResults --- $ > unit_configError_valid_pass +-- $> unit_configError_valid_pass unit_configError_valid_pass :: IO () unit_configError_valid_pass = chkInitFailure Nothing [MkFilterResult "" Nothing] --- $ > unit_configError_valid_fail +-- $> unit_configError_valid_fail unit_configError_valid_fail :: IO () unit_configError_valid_fail = @@ -39,12 +39,12 @@ unit_configError_valid_fail = MkFilterResult "1" Nothing ] --- $ > unit_configError_empty +-- $> unit_configError_empty unit_configError_empty :: IO () unit_configError_empty = chkInitFailure (Just "Filtered Test Suite is Empty") [] --- $ > unit_configError_duplicate +-- $> unit_configError_duplicate unit_configError_duplicate :: IO () unit_configError_duplicate = From f9324b6c45fb80b0da7311ed9c92f8edcb1f3038 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 28 Sep 2024 23:01:15 +0000 Subject: [PATCH 31/43] add comments --- src/Internal/Logging.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 8a3cd8f6..a4a6c85a 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -215,6 +215,11 @@ data Log loc nodeLog testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Log l a), STM [FullLog LineInfo (Log l a)]) testLogActions = testLogActions' mkLogSinkGenerator +-- Given a base sink that will send a FullLog (including line info) into IO (), this function +-- creates a Logger generator by intialising a new logger for the thread it is called in +-- (so the thread id, index IORef and potentially other IO properties such as agent, shard and timezone can be used) +-- and then returns a function that will send an unexpanded Log through to IO () by adding the line info +-- and sending it to the base (FullLog) sink mkLogSinkGenerator :: forall l a. (FullLog LineInfo (Log l a) -> IO ()) -> IO (Log l a -> IO ()) mkLogSinkGenerator fullSink = logNext <$> UnliftIO.newIORef (-1) <*> P.myThreadId From d38912f6ef0ff88e1df820d0de95035ad4a2f31d Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 29 Sep 2024 00:07:02 +0000 Subject: [PATCH 32/43] a bit of clean up --- examples/LazyinessSuiteDemo.hs | 119 +++++++++++++++++++++++++++++++++ examples/WebDriverDemo.hs | 62 +---------------- pyrethrum.cabal | 3 +- 3 files changed, 122 insertions(+), 62 deletions(-) create mode 100644 examples/LazyinessSuiteDemo.hs diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs new file mode 100644 index 00000000..ad662f38 --- /dev/null +++ b/examples/LazyinessSuiteDemo.hs @@ -0,0 +1,119 @@ +module LazyinessSuiteDemo where + +import Check +import Core (ParseException) +import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Info)) +import DSL.OutEffect (Out, out) +import Effectful as EF + ( Eff, + type (:>), + ) +import PyrethrumBase +import PyrethrumExtras (txt) +import WebDriverEffect as WE +import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) +import Filter (Filters(..)) +import Internal.SuiteRuntime (ThreadCount(..)) +import Internal.Logging qualified as L +import WebDriverPure (seconds) +import DSL.Logging (log) + + +-- ################### Effectful Demo ################## + +_theInternet :: Text +_theInternet = "https://the-internet.herokuapp.com/" + +_checkBoxesLinkCss :: Selector +_checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" + +runDemo :: SuiteRunner -> Suite -> IO () +runDemo runner suite' = do + (logControls, _logLst) <- L.testLogActions True + runner suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls + +-- start geckodriver first: geckodriver & +runIODemo :: Suite -> IO () +runIODemo = runDemo ioRunner + +-- ############### Test Case With Lazy Errors ################### + +{- +todo: + - check why no callstack :: skip wait till ghc upgrade + - laziness - esp hooks + - exceptions from hooks and actions + - finish doc interpreter poc + - merge +-} + +lazyDemo :: IO () +lazyDemo = runIODemo suiteLzFail +--- >>> lazyDemo + +suiteLzFail :: Suite +suiteLzFail = + [Fixture (NodePath "WebDriverDemo" "test") testLazy] + + +config :: FixtureConfig +config = FxCfg "test" DeepRegression + +testLazy :: Fixture () +testLazy = Full config action_fail parseLzFail itemsLzFail + +driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus +driver_status_fail = do + status <- driverStatus + log $ "the driver status is: " <> txt status + pure $ error "BANG !!!! driver status failed !!!" + +action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Data -> Eff es AS +action_fail _rc i = do + log i.title + status <- driver_status_fail + -- log $ "the driver status is (from test): " <> txt status + ses <- newSession + maximiseWindow ses + go ses _theInternet + link <- findElem ses _checkBoxesLinkCss + checkButtonText <- readElem ses link + clickElem ses link + -- so we can see the navigation worked + sleep $ 5 * seconds + killSession ses + pure $ AS {status, checkButtonText} + +data AS = AS + { status :: DriverStatus, + checkButtonText :: Text + } + deriving (Show) + +data DS = DS + { status :: DriverStatus, + checkButtonText :: Text + } + deriving (Show) + +data Data = Item + { id :: Int, + title :: Text, + checks :: Checks DS + } + deriving (Show, Read) + +parseLzFail :: AS -> Either ParseException DS +parseLzFail AS {..} = pure $ DS {..} + +itemsLzFail :: RunConfig -> DataSource Data +itemsLzFail _rc = + ItemList + [ Item + { id = 1, + title = "test the internet", + checks = + chk "Driver is ready" ((== Ready) . (.status)) + <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) + } + ] diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index 4840c91e..9d14da86 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -104,64 +104,4 @@ items _rc = chk "Driver is ready" ((== Ready) . (.status)) <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) } - ] - --- ############### Test Case With Lazy Errors ################### - -{- -todo: - - exceptions in selenium - - check why no callstack - - laziness - esp hooks - - finish doc interpreter poc - - merge --} - ---- >>> lazyDemo -lazyDemo :: IO () -lazyDemo = runIODemo suiteLzFail - -suiteLzFail :: Suite -suiteLzFail = - [Fixture (NodePath "WebDriverDemo" "test") testLazy] - - -testLazy :: Fixture () -testLazy = Full config action_fail parseLzFail itemsLzFail - -driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus -driver_status_fail = do - status <- driverStatus - log $ "the driver status is: " <> txt status - pure $ error "BANG !!!! driver status failed !!!" - -action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Data -> Eff es AS -action_fail _rc i = do - log i.title - status <- driver_status_fail - -- log $ "the driver status is (from test): " <> txt status - ses <- newSession - maximiseWindow ses - go ses _theInternet - link <- findElem ses _checkBoxesLinkCss - checkButtonText <- readElem ses link - clickElem ses link - -- so we can see the navigation worked - sleep $ 5 * seconds - killSession ses - pure $ AS {status, checkButtonText} - -parseLzFail :: AS -> Either ParseException DS -parseLzFail AS {..} = pure $ DS {..} - -itemsLzFail :: RunConfig -> DataSource Data -itemsLzFail _rc = - ItemList - [ Item - { id = 1, - title = "test the internet", - checks = - chk "Driver is ready" ((== Ready) . (.status)) - <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) - } - ] + ] \ No newline at end of file diff --git a/pyrethrum.cabal b/pyrethrum.cabal index 5d8b6adb..c155e316 100644 --- a/pyrethrum.cabal +++ b/pyrethrum.cabal @@ -4,7 +4,7 @@ cabal-version: 3.6 -- -- see: https://github.com/sol/hpack -- --- hash: 6fd4ef585454e85aa2ab5d4c7fe48c315eb256929b9fb58776234d11098d5866 +-- hash: 54d8765ec1817c0fffa481b4b3a8171458f8de785bfc7618961d0f210fa2271e name: pyrethrum version: 0.1.0.0 @@ -116,6 +116,7 @@ library FileSystemDocDemo HigherOrderEffectDemo IOEffectDemo + LazyinessSuiteDemo PyrethrumBase PyrethrumConfigTypes PyrethrumDemoTest From 4a1045841444a5fb3af6b164134e82ac72694ef1 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 29 Sep 2024 21:21:10 +0000 Subject: [PATCH 33/43] Created exception issue --- examples/DocumenterDemo.hs | 1 - examples/LazyinessSuiteDemo.hs | 72 ++++++++++++++++++++++++---------- 2 files changed, 52 insertions(+), 21 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 8d1f31f2..5a2c4c16 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -214,7 +214,6 @@ intOnceHook = log "This is the inner hook" log "Run once before the test" pure 8 - -- pure $ error "HOOK BANG !!!" } --- Fixture --- diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index ad662f38..b61d0a55 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -1,7 +1,7 @@ module LazyinessSuiteDemo where import Check -import Core (ParseException) +import Core (ParseException, Once, Before) import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Info)) import DSL.OutEffect (Out, out) import Effectful as EF @@ -9,7 +9,7 @@ import Effectful as EF type (:>), ) import PyrethrumBase -import PyrethrumExtras (txt) +import PyrethrumExtras (txt, (?)) import WebDriverEffect as WE import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) import Filter (Filters(..)) @@ -47,42 +47,74 @@ todo: - merge -} +blowUpInGetStatus :: Bool +blowUpInGetStatus = True + lazyDemo :: IO () lazyDemo = runIODemo suiteLzFail --- >>> lazyDemo + +-- $> lazyDemo + suiteLzFail :: Suite suiteLzFail = - [Fixture (NodePath "WebDriverDemo" "test") testLazy] + [ Hook + (NodePath "WebDriverDemo" "before") + nothingBefore + [ Hook + (NodePath "WebDriverDemo" "beforeInner") + driverStatusOnceHook + [ Fixture (NodePath "WebDriverDemo" "test") testLazy + ] + ] + ] + + -- [Fixture (NodePath "WebDriverDemo" "test") testLazy] config :: FixtureConfig config = FxCfg "test" DeepRegression -testLazy :: Fixture () -testLazy = Full config action_fail parseLzFail itemsLzFail +testLazy :: Fixture DriverStatus +testLazy = Full' config driverStatusOnceHook action_fail parseLzFail itemsLzFail + +--- Hook --- + +nothingBefore :: Hook Once Before () () +nothingBefore = + BeforeHook + { action = \_rc -> do + log "This is the outer hook" + log "Run once before the test" + } + +driverStatusOnceHook :: Hook Once Before () DriverStatus +driverStatusOnceHook = + BeforeHook' + { depends = nothingBefore, + action' = \_rc _void -> do + log "This is the inner hook" + log "Run once before the test" + -- driver_status_fail + pure $ error "BANG !!!! Hook failed !!!" + } driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus driver_status_fail = do + status <- driverStatus - log $ "the driver status is: " <> txt status + -- fails here when driver not running status forced + -- log $ "the driver status is: " <> txt status + -- pure $ blowUpInGetStatus ? status $ Ready pure $ error "BANG !!!! driver status failed !!!" -action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> Data -> Eff es AS -action_fail _rc i = do - log i.title +action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS +action_fail _rc i itm = do + log itm.title + log $ txt i status <- driver_status_fail - -- log $ "the driver status is (from test): " <> txt status - ses <- newSession - maximiseWindow ses - go ses _theInternet - link <- findElem ses _checkBoxesLinkCss - checkButtonText <- readElem ses link - clickElem ses link - -- so we can see the navigation worked - sleep $ 5 * seconds - killSession ses - pure $ AS {status, checkButtonText} + pure $ AS {status, checkButtonText = "Checkboxes"} data AS = AS { status :: DriverStatus, From a556eb7b63d3ac60fe9c6d415436033258940197 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Wed, 2 Oct 2024 19:52:50 +0000 Subject: [PATCH 34/43] wip --- examples/DocumenterDemo.hs | 4 ++-- examples/LazyinessSuiteDemo.hs | 43 +++++++++++++++++----------------- examples/WebDriverDemo.hs | 4 ++-- 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/examples/DocumenterDemo.hs b/examples/DocumenterDemo.hs index 5a2c4c16..4309804d 100644 --- a/examples/DocumenterDemo.hs +++ b/examples/DocumenterDemo.hs @@ -32,7 +32,6 @@ import PyrethrumExtras (Abs, File, relfile, toS, txt, (?)) import WebDriverEffect ( WebUI, clickElem, - driverStatus, findElem, go, killSession, @@ -224,7 +223,8 @@ test = Full' config intOnceHook action parse items config :: FixtureConfig config = FxCfg "test" DeepRegression -driver_status :: (WebUI :> es) => Eff es DriverStatus +-- driver_status :: (WebUI :> es) => Eff es DriverStatus +driver_status :: Eff es DriverStatus driver_status = pure $ error "This is a lazy error !!!" -- driver_status = driverStatus diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index b61d0a55..1259a392 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -2,20 +2,18 @@ module LazyinessSuiteDemo where import Check import Core (ParseException, Once, Before) -import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Info)) -import DSL.OutEffect (Out, out) +import DSL.Internal.NodeLog (NodeLog, Path (NodePath)) +import DSL.OutEffect (Out) import Effectful as EF ( Eff, type (:>), ) import PyrethrumBase -import PyrethrumExtras (txt, (?)) import WebDriverEffect as WE import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) import Filter (Filters(..)) import Internal.SuiteRuntime (ThreadCount(..)) import Internal.Logging qualified as L -import WebDriverPure (seconds) import DSL.Logging (log) @@ -47,12 +45,11 @@ todo: - merge -} -blowUpInGetStatus :: Bool -blowUpInGetStatus = True lazyDemo :: IO () lazyDemo = runIODemo suiteLzFail --- >>> lazyDemo +-- *** Exception: BANG !!!! driverStatusOnceHook Hook failed !!! -- $> lazyDemo @@ -64,7 +61,7 @@ suiteLzFail = nothingBefore [ Hook (NodePath "WebDriverDemo" "beforeInner") - driverStatusOnceHook + pureErrorHook [ Fixture (NodePath "WebDriverDemo" "test") testLazy ] ] @@ -77,7 +74,7 @@ config :: FixtureConfig config = FxCfg "test" DeepRegression testLazy :: Fixture DriverStatus -testLazy = Full' config driverStatusOnceHook action_fail parseLzFail itemsLzFail +testLazy = Full' config pureErrorHook action_fail parseLzFail itemsLzFail --- Hook --- @@ -86,35 +83,37 @@ nothingBefore = BeforeHook { action = \_rc -> do log "This is the outer hook" - log "Run once before the test" } -driverStatusOnceHook :: Hook Once Before () DriverStatus -driverStatusOnceHook = +pureErrorHook :: Hook Once Before () DriverStatus +pureErrorHook = BeforeHook' { depends = nothingBefore, action' = \_rc _void -> do log "This is the inner hook" - log "Run once before the test" -- driver_status_fail - pure $ error "BANG !!!! Hook failed !!!" + -- pure Ready + pure $ error "BANG !!!! driverStatusOnceHook Hook failed !!!" + -- error "BANG !!!! driverStatusOnceHook Hook failed !!!" } -driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus +-- driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus +driver_status_fail :: (WebUI :> es) => Eff es DriverStatus driver_status_fail = do - - status <- driverStatus + _status <- driverStatus -- fails here when driver not running status forced -- log $ "the driver status is: " <> txt status -- pure $ blowUpInGetStatus ? status $ Ready - pure $ error "BANG !!!! driver status failed !!!" + pure $ error "BOOM %%%% driver status failed %%%%" -action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS -action_fail _rc i itm = do +-- action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS +action_fail :: (Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS +action_fail _rc _hookDriverStatus itm = do log itm.title - log $ txt i - status <- driver_status_fail - pure $ AS {status, checkButtonText = "Checkboxes"} + -- log $ txt hookDriverStatus + -- status <- driver_status_fail + -- pure $ AS {status, checkButtonText = "Checkboxes"} + pure $ AS {status = Ready, checkButtonText = "Checkboxes"} data AS = AS { status :: DriverStatus, diff --git a/examples/WebDriverDemo.hs b/examples/WebDriverDemo.hs index 9d14da86..87edb1a8 100644 --- a/examples/WebDriverDemo.hs +++ b/examples/WebDriverDemo.hs @@ -2,8 +2,8 @@ module WebDriverDemo where import Check import Core (ParseException) -import DSL.Internal.NodeLog (NodeLog (User), Path (NodePath), UserLog (Info)) -import DSL.OutEffect (Out, out) +import DSL.Internal.NodeLog (NodeLog, Path (NodePath)) +import DSL.OutEffect (Out) import Effectful as EF ( Eff, type (:>), From c59fa74a9daf6ad64844b5adb48f0a68263e0f2c Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 3 Oct 2024 22:34:48 +0000 Subject: [PATCH 35/43] WIP --- DockerfileHaskell | 1 + examples/LazyinessSuiteDemo.hs | 120 ++++++++++++++++++++++++--------- 2 files changed, 88 insertions(+), 33 deletions(-) diff --git a/DockerfileHaskell b/DockerfileHaskell index 2f02403b..54cbd3d5 100644 --- a/DockerfileHaskell +++ b/DockerfileHaskell @@ -57,6 +57,7 @@ RUN apt-get update && \ # Ensure the vscode user has ownership of the ghciwatch binary RUN chown ${USER_UID}:${USER_GID} /usr/local/bin/ghciwatch + # Set working directory and path for vscode user USER ${USER_UID}:${USER_GID} WORKDIR /home/${USERNAME} ENV PATH="/home/${USERNAME}/.local/bin:/home/${USERNAME}/.cabal/bin:/home/${USERNAME}/.ghcup/bin:$PATH" diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index 1259a392..e6882fc0 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -8,13 +8,19 @@ import Effectful as EF ( Eff, type (:>), ) -import PyrethrumBase +import PyrethrumBase hiding (Hook) +import PyrethrumBase qualified as PB import WebDriverEffect as WE import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) import Filter (Filters(..)) import Internal.SuiteRuntime (ThreadCount(..)) import Internal.Logging qualified as L import DSL.Logging (log) +import UnliftIO (catchAny) +import Data.Text.IO qualified as TIO +import Data.Text (pack) +import BasePrelude (throw) +import GHC.Records (HasField) -- ################### Effectful Demo ################## @@ -38,28 +44,25 @@ runIODemo = runDemo ioRunner {- todo: - - check why no callstack :: skip wait till ghc upgrade - - laziness - esp hooks - - exceptions from hooks and actions - - finish doc interpreter poc - - merge + - fix log flushing + - fix error handling -} lazyDemo :: IO () lazyDemo = runIODemo suiteLzFail --- >>> lazyDemo --- *** Exception: BANG !!!! driverStatusOnceHook Hook failed !!! +-- *** Exception: BANG !!!! pureErrorHook Hook failed !!! -- $> lazyDemo suiteLzFail :: Suite suiteLzFail = - [ Hook + [ PB.Hook (NodePath "WebDriverDemo" "before") nothingBefore - [ Hook + [ PB.Hook (NodePath "WebDriverDemo" "beforeInner") pureErrorHook [ Fixture (NodePath "WebDriverDemo" "test") testLazy @@ -67,25 +70,23 @@ suiteLzFail = ] ] - -- [Fixture (NodePath "WebDriverDemo" "test") testLazy] - config :: FixtureConfig config = FxCfg "test" DeepRegression testLazy :: Fixture DriverStatus -testLazy = Full' config pureErrorHook action_fail parseLzFail itemsLzFail +testLazy = Full' config pureErrorHook action' parse items --- Hook --- -nothingBefore :: Hook Once Before () () +nothingBefore :: PB.Hook Once Before () () nothingBefore = BeforeHook { action = \_rc -> do log "This is the outer hook" } -pureErrorHook :: Hook Once Before () DriverStatus +pureErrorHook :: PB.Hook Once Before () DriverStatus pureErrorHook = BeforeHook' { depends = nothingBefore, @@ -93,26 +94,15 @@ pureErrorHook = log "This is the inner hook" -- driver_status_fail -- pure Ready - pure $ error "BANG !!!! driverStatusOnceHook Hook failed !!!" - -- error "BANG !!!! driverStatusOnceHook Hook failed !!!" + pure $ error "BANG !!!! pureErrorHook Hook failed !!!" + -- error "BANG !!!! pureErrorHook Hook failed !!!" } --- driver_status_fail :: (WebUI :> es, Out NodeLog :> es) => Eff es DriverStatus -driver_status_fail :: (WebUI :> es) => Eff es DriverStatus -driver_status_fail = do - _status <- driverStatus - -- fails here when driver not running status forced - -- log $ "the driver status is: " <> txt status - -- pure $ blowUpInGetStatus ? status $ Ready - pure $ error "BOOM %%%% driver status failed %%%%" -- action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS -action_fail :: (Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS -action_fail _rc _hookDriverStatus itm = do +action' :: (Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS +action' _rc _hookDriverStatus itm = do log itm.title - -- log $ txt hookDriverStatus - -- status <- driver_status_fail - -- pure $ AS {status, checkButtonText = "Checkboxes"} pure $ AS {status = Ready, checkButtonText = "Checkboxes"} data AS = AS @@ -134,11 +124,11 @@ data Data = Item } deriving (Show, Read) -parseLzFail :: AS -> Either ParseException DS -parseLzFail AS {..} = pure $ DS {..} +parse :: AS -> Either ParseException DS +parse AS {..} = pure $ DS {..} -itemsLzFail :: RunConfig -> DataSource Data -itemsLzFail _rc = +items :: RunConfig -> DataSource Data +items _rc = ItemList [ Item { id = 1, @@ -148,3 +138,67 @@ itemsLzFail _rc = <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText)) } ] + + +-- ################### Simplified ################## + +log_ :: Text -> IO () +log_ = TIO.putStrLn +data Hook a = Hook { + description :: Text, + action :: () -> IO a + } + +data Test a = Test { + description :: Text, + action :: a -> IO () +} + +runner :: (HasField "action" n (t -> IO b), HasField "description" n Text) => n -> t -> IO b +runner node input = do + log_ $ "Running " <> node.description + catchAny (node.action input) $ \e -> do + log_ $ "Caught exception trying to run " <> node.description <> "\nYou better fix this:\n" <> pack (displayException e) + >> throw e + +runTheTest :: Hook a -> Test a -> IO () +runTheTest hook test = + log_ "" >> + log_ "##########################################" >> + runner hook () >>= runner test + +-- ################### Test ################## + +workingExample :: IO () +workingExample = runTheTest workingHook workingTest +-- $ > workingExample + +workingHook :: Hook Text +workingHook = Hook "working hook" $ \_ -> do + log_ "working hook action" + pure "working hook Output" + +workingTest :: Test Text +workingTest = Test "working test" $ \hIn -> do + log_ $ "working test action with hook input: " <> hIn + log_ "working test action" + pure () + +-- ################### Failing Test ################## + +failExample :: IO () +failExample = runTheTest failingHook workingTest +-- $ > failExample + +failingHook :: Hook Text +failingHook = Hook "failing hook" $ \_ -> error "BANG !!!! failingHook Hook failed !!!" + +-- ################### Bombing Test ################## + +bombExample :: IO () +bombExample = runTheTest bombingHook workingTest +-- >>> bombExample +-- *** Exception: BANG !!!! bombingHook Hook failed !!! + +bombingHook :: Hook Text +bombingHook = Hook "bombing hook" $ \_ -> pure $ error "BANG !!!! bombingHook Hook failed !!!" From c555a2b4ed8331859d5c37fb6d93019bdb7f0156 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 3 Oct 2024 22:42:28 +0000 Subject: [PATCH 36/43] use replicateConcurrently_ --- src/Internal/SuiteRuntime.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 4134cac5..25448cc5 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -10,9 +10,9 @@ import Internal.SuiteValidation (SuiteValidationError (..)) import Prepare qualified as P import PyrethrumExtras (txt, (?)) import UnliftIO - ( tryAny, - finally, - forConcurrently_, + ( finally, + replicateConcurrently_, + tryAny, writeTMVar, ) import UnliftIO.STM @@ -47,7 +47,7 @@ execute tc lc prms = L.runWithLogger lc execute' where execute' :: L.Loggers Log -> IO () - execute' l@L.MkLoggers{rootLogger} = + execute' l@L.MkLoggers {rootLogger} = do P.prepare prms & either @@ -69,16 +69,14 @@ executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = do finally ( rootLogger L.StartExecution - >> forConcurrently_ - thrdTokens - ( const do + >> replicateConcurrently_ + tc.maxThreads + ( do logger <- newLogger runChildQ Concurrent (runNode logger $ OnceIn ()) canRunXTree nodes ) ) (rootLogger L.EndExecution) - where - thrdTokens = replicate tc.maxThreads True data ExeTree hi where OnceBefore :: From 2f1a36c877d8be753dea084673e3a916a4a6194e Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Thu, 3 Oct 2024 22:56:35 +0000 Subject: [PATCH 37/43] WIP --- src/Internal/SuiteRuntime.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 25448cc5..bcd57118 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -13,7 +13,7 @@ import UnliftIO ( finally, replicateConcurrently_, tryAny, - writeTMVar, + writeTMVar ) import UnliftIO.STM ( TQueue, @@ -26,6 +26,7 @@ import UnliftIO.STM writeTQueue, ) import Prelude hiding (All, atomically, id, newEmptyTMVarIO, newTVarIO, readMVar) +import UnliftIO.Concurrent (threadDelay) {- todo :: define defect properties with sum type type and typeclass which returns defect info @@ -76,7 +77,8 @@ executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = runChildQ Concurrent (runNode logger $ OnceIn ()) canRunXTree nodes ) ) - (rootLogger L.EndExecution) + flush log here + (rootLogger L.EndExecution >> threadDelay 10_000_000) data ExeTree hi where OnceBefore :: From c54ed9550192547a22140fc612d459cca8611dec Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Fri, 4 Oct 2024 06:44:37 +0000 Subject: [PATCH 38/43] fixed problem of log not being flushed --- examples/LazyinessSuiteDemo.hs | 5 ++-- src/Internal/Logging.hs | 47 +++++++++++++++++++--------------- src/Internal/SuiteRuntime.hs | 4 +-- 3 files changed, 30 insertions(+), 26 deletions(-) diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index e6882fc0..312b3e9c 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -10,7 +10,6 @@ import Effectful as EF ) import PyrethrumBase hiding (Hook) import PyrethrumBase qualified as PB -import WebDriverEffect as WE import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) import Filter (Filters(..)) import Internal.SuiteRuntime (ThreadCount(..)) @@ -32,9 +31,9 @@ _checkBoxesLinkCss :: Selector _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" runDemo :: SuiteRunner -> Suite -> IO () -runDemo runner suite' = do +runDemo runner' suite' = do (logControls, _logLst) <- L.testLogActions True - runner suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls + runner' suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls -- start geckodriver first: geckodriver & runIODemo :: Suite -> IO () diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index a4a6c85a..81872d6a 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -4,20 +4,23 @@ module Internal.Logging where -- TODO: Explicit exports remove old code +-- TODO: Explicit exports remove old code +import BasePrelude qualified as P import CoreUtils (Hz (..)) import CoreUtils qualified as C import DSL.Internal.NodeLog qualified as NE import Data.Aeson.TH (defaultOptions, deriveJSON, deriveToJSON) import Data.Text as T (intercalate) +import Effectful.Concurrent.STM (TQueue, retry) import Filter (FilterResult) import PyrethrumExtras as PE (head, tail, (?)) -import Prelude hiding (atomically, lines) - --- TODO: Explicit exports remove old code -import BasePrelude qualified as P -import Effectful.Concurrent.STM (TQueue) import Text.Show.Pretty (pPrint) -import UnliftIO (concurrently_, finally, newIORef, tryReadTQueue) +import UnliftIO + ( concurrently_, + finally, + newIORef, + tryReadTQueue, + ) import UnliftIO.Concurrent (ThreadId) import UnliftIO.STM (atomically, newTChanIO, newTQueueIO, readTChan, writeTChan, writeTQueue) import Prelude hiding (atomically, lines) @@ -58,7 +61,7 @@ runWithLogger logWorker ( finally (action loggerSource) - stopWorker + stopWorker -- >> threadDelay 10_000_000 ) -- TODO:: Logger should be wrapped in an except that sets non-zero exit code on failure @@ -79,22 +82,30 @@ q2List qu = reverse <$> recurse [] qu tryReadTQueue q >>= maybe (pure l) (\e -> recurse (e : l) q) - testLogActions' :: forall l lx. (Show lx) => ((lx -> IO ()) -> IO (l -> IO ())) -> Bool -> IO (LogActions l, STM [lx]) testLogActions' mkNewSink wantConsole = do chn <- newTChanIO log <- newTQueueIO + done <- newTVarIO False -- https://stackoverflow.com/questions/32040536/haskell-forkio-threads-writing-on-top-of-each-other-with-putstrln let logWorker :: IO () logWorker = atomically (readTChan chn) >>= maybe - (pure ()) + (atomically $ writeTVar done True) (\evt -> when wantConsole (pPrint evt) >> logWorker) stopWorker :: IO () - stopWorker = atomically $ writeTChan chn Nothing + stopWorker = + atomically (writeTChan chn Nothing) + -- must be 2 separate atomic actions + >> atomically waitDone + + waitDone :: STM () + waitDone = do + emt <- readTVar done + emt ? pure () $ retry sink :: lx -> IO () sink eventLog = @@ -109,7 +120,6 @@ testLogActions' mkNewSink wantConsole = do {- Logging functions specialised to Event type -} - data LineInfo = MkLineInfo { threadId :: C.ThreadId, idx :: Int @@ -123,9 +133,9 @@ data NodeType | Test deriving (Show, Eq, Ord, Generic, NFData) -newtype ExePath = ExePath {un :: [NE.Path]} - deriving (Show, Eq, Ord) - deriving newtype NFData +newtype ExePath = ExePath {un :: [NE.Path]} + deriving (Show, Eq, Ord) + deriving newtype (NFData) topPath :: ExePath -> Maybe NE.Path topPath = PE.head . coerce @@ -215,13 +225,13 @@ data Log loc nodeLog testLogActions :: forall l a. (Show a, Show l) => Bool -> IO (LogActions (Log l a), STM [FullLog LineInfo (Log l a)]) testLogActions = testLogActions' mkLogSinkGenerator --- Given a base sink that will send a FullLog (including line info) into IO (), this function +-- Given a base sink that will send a FullLog (including line info) into IO (), this function -- creates a Logger generator by intialising a new logger for the thread it is called in --- (so the thread id, index IORef and potentially other IO properties such as agent, shard and timezone can be used) +-- (so the thread id, index IORef and potentially other IO properties such as agent, shard and timezone can be used) -- and then returns a function that will send an unexpanded Log through to IO () by adding the line info -- and sending it to the base (FullLog) sink mkLogSinkGenerator :: forall l a. (FullLog LineInfo (Log l a) -> IO ()) -> IO (Log l a -> IO ()) -mkLogSinkGenerator fullSink = +mkLogSinkGenerator fullSink = logNext <$> UnliftIO.newIORef (-1) <*> P.myThreadId where addLineInfo :: C.ThreadId -> Int -> Log l a -> FullLog LineInfo (Log l a) @@ -234,10 +244,7 @@ mkLogSinkGenerator fullSink = let nxt = succ tc finally (fullSink $ addLineInfo (C.mkThreadId thrdId) nxt logEvnt) $ writeIORef idxRef nxt - $(deriveToJSON defaultOptions ''ExePath) $(deriveJSON defaultOptions ''HookPos) $(deriveJSON defaultOptions ''NodeType) $(deriveToJSON defaultOptions ''Log) - - diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index bcd57118..866912f6 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -26,7 +26,6 @@ import UnliftIO.STM writeTQueue, ) import Prelude hiding (All, atomically, id, newEmptyTMVarIO, newTVarIO, readMVar) -import UnliftIO.Concurrent (threadDelay) {- todo :: define defect properties with sum type type and typeclass which returns defect info @@ -77,8 +76,7 @@ executeNodes L.MkLoggers {rootLogger, newLogger} nodes tc = runChildQ Concurrent (runNode logger $ OnceIn ()) canRunXTree nodes ) ) - flush log here - (rootLogger L.EndExecution >> threadDelay 10_000_000) + (rootLogger L.EndExecution) data ExeTree hi where OnceBefore :: From 9e4f66a53d3452e28d80f8838114620254e59a84 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sat, 5 Oct 2024 00:30:13 +0000 Subject: [PATCH 39/43] WIP --- examples/LazyinessSuiteDemo.hs | 2 -- src/Internal/SuiteRuntime.hs | 24 ++++++++++++++++++++---- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index 312b3e9c..2a5e0e83 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -40,14 +40,12 @@ runIODemo :: Suite -> IO () runIODemo = runDemo ioRunner -- ############### Test Case With Lazy Errors ################### - {- todo: - fix log flushing - fix error handling -} - lazyDemo :: IO () lazyDemo = runIODemo suiteLzFail --- >>> lazyDemo diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index 866912f6..f85bb6ce 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -13,7 +13,7 @@ import UnliftIO ( finally, replicateConcurrently_, tryAny, - writeTMVar + writeTMVar, catchAny ) import UnliftIO.STM ( TQueue, @@ -377,9 +377,13 @@ ioRight = pure . Right noImpPropertyError :: any noImpPropertyError = error "property tests not implemented" +logReturnFailPoint :: SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO L.FailPoint +logReturnFailPoint lgr p et e = + lgr (L.mkFailure p et e) >> pure (L.FailPoint p et) + logReturnFailure :: SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO (Either L.FailPoint b) logReturnFailure lgr p et e = - lgr (L.mkFailure p et e) >> ioLeft (L.FailPoint p et) + logReturnFailPoint lgr p et e >>= ioLeft data CanAbandon = None | Partial | All deriving (Show, Eq) @@ -640,7 +644,8 @@ runNode lgr hi xt = pure $ QElementRun True mkTestPath :: forall a. P.Test IO a -> L.ExePath - mkTestPath P.MkTest {id, title = ttl} = L.ExePath $ N.TestPath {id, title = ttl} : coerce xt.path {- fixture path -} + mkTestPath P.MkTest {id, title = ttl} = L.ExePath $ N.TestPath {id, title = ttl} : coerce xt.path + abandonSubs :: forall a. L.FailPoint -> ChildQ (ExeTree a) -> IO QElementRun abandonSubs fp = runSubNodes (Abandon fp) @@ -725,7 +730,18 @@ runNode lgr hi xt = onceRun hookRun childQRun = childQRun >>= \qr -> pure $ QElementRun $ hookRun || qr.hasRun run :: NodeIn hi' -> ExeTree hi' -> IO QElementRun - run = + run nodeIn xtree = + catchAny + (runNoCatch nodeIn xtree) + (\e -> do + -- todo calculate node type + fp <- logReturnFailPoint lgr xtree.path (Hook Once Before) e + -- TODO call run with new Abandon ??? failPoint + -- abandonSubs fp xtree.subNodes + ) + + runNoCatch :: NodeIn hi' -> ExeTree hi' -> IO QElementRun + runNoCatch = \cases -- For Once* we assume tree shaking has been executed prior to execution. -- There is no possibility of empty subnodes due to tree shaking, so these hooks will always From 45b4d6b968b20f958ce2f9c8bfcbbee31839f3fe Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 6 Oct 2024 00:17:33 +0000 Subject: [PATCH 40/43] WIP capturing exception --- src/Internal/LogQueries.hs | 5 +++++ src/Internal/Logging.hs | 8 ++++++++ src/Internal/SuiteRuntime.hs | 28 ++++++++++++++++++++-------- test/SuiteRuntimeTestBase.hs | 9 +++++++++ 4 files changed, 42 insertions(+), 8 deletions(-) diff --git a/src/Internal/LogQueries.hs b/src/Internal/LogQueries.hs index b084adcd..1e0cd97c 100644 --- a/src/Internal/LogQueries.hs +++ b/src/Internal/LogQueries.hs @@ -87,6 +87,7 @@ threadEventToBool prd = suitEvntToBool prd . getSuiteEvent startEndNodeMatch :: (NodeType -> Bool) -> FLog l a -> Bool startEndNodeMatch p l = evnt l & \case StartExecution {} -> False + InitialisationFailure {} -> False Failure {} -> False ParentFailure {} -> False NodeLog {} -> False @@ -115,6 +116,7 @@ suiteEventOrParentFailureSuiteEvent l = StartExecution {} -> Nothing Start {nodeType = s} -> Just s End {nodeType = s} -> Just s + InitialisationFailure {} -> Nothing Failure {} -> Nothing ParentFailure {nodeType = s} -> Just s NodeLog {} -> Nothing @@ -127,6 +129,7 @@ getSuiteEvent l = evnt l & \case Start {nodeType} -> Just nodeType End {nodeType} -> Just nodeType ParentFailure {nodeType} -> Just nodeType + InitialisationFailure {nodeType} -> Just nodeType Failure {nodeType} -> Just nodeType StartExecution {} -> Nothing NodeLog {} -> Nothing @@ -146,6 +149,7 @@ startOrParentFailure l = evnt l & \case EndExecution {} -> False NodeLog {} -> False Failure {} -> False + InitialisationFailure {} -> False -- event will either have a start or be -- represented by a parent failure if skipped ParentFailure {} -> True @@ -160,6 +164,7 @@ startSuiteEventLoc l = evnt l & \case EndExecution {} -> Nothing NodeLog {} -> Nothing Failure {} -> Nothing + InitialisationFailure {} -> Nothing -- event will either have a start or be -- represented by a parent failure if skipped ParentFailure {loc} -> Just loc diff --git a/src/Internal/Logging.hs b/src/Internal/Logging.hs index 81872d6a..657903e0 100644 --- a/src/Internal/Logging.hs +++ b/src/Internal/Logging.hs @@ -188,6 +188,9 @@ data FailPoint = FailPoint mkFailure :: l -> NodeType -> SomeException -> Log l a mkFailure loc nodeType exception = Failure {exception = C.exceptionTxt exception, ..} +mkInitFailure :: l -> NodeType -> SomeException -> Log l a +mkInitFailure loc nodeType exception = InitialisationFailure {exception = C.exceptionTxt exception, ..} + data Log loc nodeLog = FilterLog { filterResuts :: [FilterResult Text] @@ -205,6 +208,11 @@ data Log loc nodeLog { nodeType :: NodeType, loc :: loc } + | InitialisationFailure + { nodeType :: NodeType, + loc :: loc, + exception :: C.PException + } | Failure { nodeType :: NodeType, loc :: loc, diff --git a/src/Internal/SuiteRuntime.hs b/src/Internal/SuiteRuntime.hs index f85bb6ce..99d45c50 100644 --- a/src/Internal/SuiteRuntime.hs +++ b/src/Internal/SuiteRuntime.hs @@ -377,13 +377,13 @@ ioRight = pure . Right noImpPropertyError :: any noImpPropertyError = error "property tests not implemented" -logReturnFailPoint :: SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO L.FailPoint -logReturnFailPoint lgr p et e = - lgr (L.mkFailure p et e) >> pure (L.FailPoint p et) +logReturnFailPoint :: Bool -> SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO L.FailPoint +logReturnFailPoint inInitialisation lgr p et e = + lgr ((inInitialisation ? L.mkInitFailure $ L.mkFailure) p et e) >> pure (L.FailPoint p et) logReturnFailure :: SuiteLogger -> L.ExePath -> NodeType -> SomeException -> IO (Either L.FailPoint b) logReturnFailure lgr p et e = - logReturnFailPoint lgr p et e >>= ioLeft + logReturnFailPoint False lgr p et e >>= ioLeft data CanAbandon = None | Partial | All deriving (Show, Eq) @@ -735,9 +735,8 @@ runNode lgr hi xt = (runNoCatch nodeIn xtree) (\e -> do -- todo calculate node type - fp <- logReturnFailPoint lgr xtree.path (Hook Once Before) e - -- TODO call run with new Abandon ??? failPoint - -- abandonSubs fp xtree.subNodes + fp <- logReturnFailPoint True lgr xtree.path (initFailureNodeType xtree) e + run (Abandon fp) xtree ) runNoCatch :: NodeIn hi' -> ExeTree hi' -> IO QElementRun @@ -1067,11 +1066,24 @@ data NodeIn hi where NodeIn hi data TestContext hi = MkTestContext - { -- hookIn :: IO (Either L.FailPoint hi), + { hookIn :: Either L.FailPoint hi, after :: IO () } +initFailureNodeType :: ExeTree hi -> NodeType +initFailureNodeType = \case + OnceBefore {} -> Hook Once Before + OnceAround {} -> Hook Once Setup + OnceAfter {} -> Hook Once After + ThreadBefore {} -> Hook Thread Before + ThreadAround {} -> Hook Thread Setup + ThreadAfter {} -> Hook Thread After + EachBefore {} -> Hook Each Before + EachAround {} -> Hook Each Setup + EachAfter {} -> Hook Each After + Fixture {} -> L.Test + mkTestContext :: forall hi ho. Either L.FailPoint hi -> IO () -> (Either L.FailPoint hi -> IO (Either L.FailPoint ho)) -> (Either L.FailPoint ho -> IO ()) -> IO (TestContext ho) mkTestContext parentIn afterParent setupNxt teardownNxt = -- must be in IO so teardown has access to ho diff --git a/test/SuiteRuntimeTestBase.hs b/test/SuiteRuntimeTestBase.hs index f59412b4..ff7e0596 100644 --- a/test/SuiteRuntimeTestBase.hs +++ b/test/SuiteRuntimeTestBase.hs @@ -228,6 +228,11 @@ logAccum acc@(passStart, rMap) (MkLog {event}) = isJust passStart ? (Nothing, insert' loc nodeType $ Actual Fail) $ error ("Failure event not started\n" <> txt f) + + -- TODO this is probably wrong fix this will cause failures when tests generate these + -- need to think about cortrect expected results in this case + InitialisationFailure {} -> acc + pf@ParentFailure {loc, nodeType} -> isJust passStart ? error ("parent failure encountered when parent event not ended\n" <> txt pf) @@ -526,6 +531,10 @@ failInfo ls = & maybe (error $ "Failure encountered before start:\n" <> toS (ppShow l)) (const (Nothing, FailInfo l ls' : result)) + + -- todo think about logic here + InitialisationFailure {} -> passThrough + ParentFailure {} -> passThrough StartExecution {} -> passThrough EndExecution {} -> passThrough From a80c8f2b8349e3c5357f2457e3c3e5087416c3cc Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Sun, 6 Oct 2024 20:42:17 +0000 Subject: [PATCH 41/43] WIP - a couple mre demos --- examples/LazyinessSuiteDemo.hs | 154 ++++++++++++++++++++++----------- 1 file changed, 103 insertions(+), 51 deletions(-) diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index 2a5e0e83..eeb06967 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -1,26 +1,25 @@ module LazyinessSuiteDemo where +import BasePrelude (throw) import Check -import Core (ParseException, Once, Before) +import Core (Before, Each, Once, ParseException) import DSL.Internal.NodeLog (NodeLog, Path (NodePath)) +import DSL.Logging (log) import DSL.OutEffect (Out) +import Data.Text (pack) +import Data.Text.IO qualified as TIO import Effectful as EF ( Eff, type (:>), ) +import Filter (Filters (..)) +import GHC.Records (HasField) +import Internal.Logging qualified as L +import Internal.SuiteRuntime (ThreadCount (..)) import PyrethrumBase hiding (Hook) import PyrethrumBase qualified as PB -import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) -import Filter (Filters(..)) -import Internal.SuiteRuntime (ThreadCount(..)) -import Internal.Logging qualified as L -import DSL.Logging (log) import UnliftIO (catchAny) -import Data.Text.IO qualified as TIO -import Data.Text (pack) -import BasePrelude (throw) -import GHC.Records (HasField) - +import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) -- ################### Effectful Demo ################## @@ -31,7 +30,7 @@ _checkBoxesLinkCss :: Selector _checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" runDemo :: SuiteRunner -> Suite -> IO () -runDemo runner' suite' = do +runDemo runner' suite' = do (logControls, _logLst) <- L.testLogActions True runner' suite' Unfiltered defaultRunConfig (ThreadCount 1) logControls @@ -40,39 +39,69 @@ runIODemo :: Suite -> IO () runIODemo = runDemo ioRunner -- ############### Test Case With Lazy Errors ################### -{- -todo: - - fix log flushing - - fix error handling --} -lazyDemo :: IO () -lazyDemo = runIODemo suiteLzFail ---- >>> lazyDemo --- *** Exception: BANG !!!! pureErrorHook Hook failed !!! +onceHkDeferredDemo :: IO () +onceHkDeferredDemo = runIODemo onceHkDeferredSuite +-- $ > onceHkDeferredDemo --- $> lazyDemo - -suiteLzFail :: Suite -suiteLzFail = +onceHkDeferredSuite :: Suite +onceHkDeferredSuite = [ PB.Hook (NodePath "WebDriverDemo" "before") nothingBefore [ PB.Hook (NodePath "WebDriverDemo" "beforeInner") pureErrorHook - [ Fixture (NodePath "WebDriverDemo" "test") testLazy + [ Fixture (NodePath "WebDriverDemo" "test") fxLogMessage + ] + ] + ] + +eachHkDeferredSuiteDemo :: IO () +eachHkDeferredSuiteDemo = runIODemo eachHkDeferredSuite + +-- $ > eachHkDeferredSuiteDemo + +eachHkDeferredSuite :: Suite +eachHkDeferredSuite = + [ PB.Hook + (NodePath "WebDriverDemo" "before once") + nothingBefore + [ PB.Hook + (NodePath "WebDriverDemo" "before inner once") + pureErrorHook + [ PB.Hook + (NodePath "WebDriverDemo" "each hook") + eachHook + [Fixture (NodePath "WebDriverDemo" "test") fxLogMessage] ] ] ] +eachHkFailDemo :: IO () +eachHkFailDemo = runIODemo eachHkFail + +-- $> eachHkFailDemo +-- runs effect but does not throw error because test does not use hook input +-- TODO - parameterise action with bool to use not use hook input +eachHkFail :: Suite +eachHkFail = + [ PB.Hook + (NodePath "WebDriverDemo" "before once") + nothingBefore + [ PB.Hook + (NodePath "WebDriverDemo" "each hook Gunna Blow") + eachFailureHook + [Fixture (NodePath "WebDriverDemo" "test") fxLogMessage] + ] + ] config :: FixtureConfig config = FxCfg "test" DeepRegression -testLazy :: Fixture DriverStatus -testLazy = Full' config pureErrorHook action' parse items +fxLogMessage :: Fixture DriverStatus +fxLogMessage = Full' config pureErrorHook action' parse items --- Hook --- @@ -87,16 +116,33 @@ pureErrorHook :: PB.Hook Once Before () DriverStatus pureErrorHook = BeforeHook' { depends = nothingBefore, - action' = \_rc _void -> do - log "This is the inner hook" - -- driver_status_fail - -- pure Ready - pure $ error "BANG !!!! pureErrorHook Hook failed !!!" - -- error "BANG !!!! pureErrorHook Hook failed !!!" + action' = pureError "This is the inner hook" "BANG !!!! pureErrorHook Hook failed !!!" + } + +eachHook :: PB.Hook Each Before DriverStatus DriverStatus +eachHook = + BeforeHook' + { depends = pureErrorHook, + action' = \_rc ds -> do + log "This is each hook" + pure ds + } + + +eachFailureHook :: PB.Hook Each Before () DriverStatus +eachFailureHook = + BeforeHook' + { depends = nothingBefore, + action' = \_rc _ds -> do + log "This is each hook" + pure $ error "BANG !!!! eachFailureHook Hook failed !!!" } +pureError :: (Out NodeLog :> es) => Text -> Text -> rc -> i -> Eff es b +pureError logMsg errMsg _rc _i = do + log logMsg + pure $ error errMsg --- action_fail :: (WebUI :> es, Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS action' :: (Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS action' _rc _hookDriverStatus itm = do log itm.title @@ -120,7 +166,7 @@ data Data = Item checks :: Checks DS } deriving (Show, Read) - + parse :: AS -> Either ParseException DS parse AS {..} = pure $ DS {..} @@ -136,38 +182,41 @@ items _rc = } ] - -- ################### Simplified ################## log_ :: Text -> IO () log_ = TIO.putStrLn -data Hook a = Hook { - description :: Text, - action :: () -> IO a + +data Hook a = Hook + { description :: Text, + action :: () -> IO a } -data Test a = Test { - description :: Text, - action :: a -> IO () -} +data Test a = Test + { description :: Text, + action :: a -> IO () + } runner :: (HasField "action" n (t -> IO b), HasField "description" n Text) => n -> t -> IO b runner node input = do log_ $ "Running " <> node.description - catchAny (node.action input) $ \e -> do - log_ $ "Caught exception trying to run " <> node.description <> "\nYou better fix this:\n" <> pack (displayException e) - >> throw e + catchAny (node.action input) $ \e -> + do + log_ $ "Caught exception trying to run " <> node.description <> "\nYou better fix this:\n" <> pack (displayException e) + >> throw e runTheTest :: Hook a -> Test a -> IO () -runTheTest hook test = - log_ "" >> - log_ "##########################################" >> - runner hook () >>= runner test +runTheTest hook test = + log_ "" + >> log_ "##########################################" + >> runner hook () + >>= runner test -- ################### Test ################## workingExample :: IO () workingExample = runTheTest workingHook workingTest + -- $ > workingExample workingHook :: Hook Text @@ -185,6 +234,7 @@ workingTest = Test "working test" $ \hIn -> do failExample :: IO () failExample = runTheTest failingHook workingTest + -- $ > failExample failingHook :: Hook Text @@ -194,7 +244,9 @@ failingHook = Hook "failing hook" $ \_ -> error "BANG !!!! failingHook Hook fail bombExample :: IO () bombExample = runTheTest bombingHook workingTest + -- >>> bombExample + -- *** Exception: BANG !!!! bombingHook Hook failed !!! bombingHook :: Hook Text From b5b32285bf1ae3933f052b47d0d94f99243a744b Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Mon, 7 Oct 2024 19:54:27 +0000 Subject: [PATCH 42/43] demo done --- examples/LazyinessSuiteDemo.hs | 127 ++++++++++++++++++++++----------- 1 file changed, 87 insertions(+), 40 deletions(-) diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index eeb06967..1d69f884 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -19,16 +19,11 @@ import Internal.SuiteRuntime (ThreadCount (..)) import PyrethrumBase hiding (Hook) import PyrethrumBase qualified as PB import UnliftIO (catchAny) -import WebDriverSpec (DriverStatus (Ready), Selector (CSS)) +import WebDriverSpec (DriverStatus (Ready)) +import PyrethrumExtras (txt) -- ################### Effectful Demo ################## -_theInternet :: Text -_theInternet = "https://the-internet.herokuapp.com/" - -_checkBoxesLinkCss :: Selector -_checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" - runDemo :: SuiteRunner -> Suite -> IO () runDemo runner' suite' = do (logControls, _logLst) <- L.testLogActions True @@ -38,91 +33,140 @@ runDemo runner' suite' = do runIODemo :: Suite -> IO () runIODemo = runDemo ioRunner --- ############### Test Case With Lazy Errors ################### +-- ############### Test Cases With Lazy Errors ################### onceHkDeferredDemo :: IO () onceHkDeferredDemo = runIODemo onceHkDeferredSuite --- $ > onceHkDeferredDemo +--- $> onceHkDeferredDemo +-- creates a test initialisation failure in test when once hook output is cached onceHkDeferredSuite :: Suite onceHkDeferredSuite = [ PB.Hook (NodePath "WebDriverDemo" "before") - nothingBefore + nothingOnceBefore [ PB.Hook (NodePath "WebDriverDemo" "beforeInner") - pureErrorHook - [ Fixture (NodePath "WebDriverDemo" "test") fxLogMessage + pureOnceErrorHook + [ Fixture (NodePath "WebDriverDemo" "fixture") $ fxLogMessage False ] ] ] +------------------------------------------------------ -eachHkDeferredSuiteDemo :: IO () -eachHkDeferredSuiteDemo = runIODemo eachHkDeferredSuite +-- $> threadHkInitFailSuiteDemo +-- creates an initialisation failure in each hook when thread hook output is cached --- $ > eachHkDeferredSuiteDemo +threadHkInitFailSuiteDemo :: IO () +threadHkInitFailSuiteDemo = runIODemo threadHkInitFailSuite -eachHkDeferredSuite :: Suite -eachHkDeferredSuite = +threadHkInitFailSuite :: Suite +threadHkInitFailSuite = [ PB.Hook (NodePath "WebDriverDemo" "before once") - nothingBefore + nothingOnceBefore + [ PB.Hook + (NodePath "WebDriverDemo" "before inner thread") + pureThreadErrorHook + [ PB.Hook + (NodePath "WebDriverDemo" "each hook") + eachHook + [Fixture (NodePath "WebDriverDemo" "fixture") $ fxLogMessage False] + ] + ] + ] + +------------------------------------------------------ + +--- $> eachHkInitFailSuiteDemo +-- creates an initialisation failure in each hook when once hook output is cached + +eachHkInitFailSuiteDemo :: IO () +eachHkInitFailSuiteDemo = runIODemo eachHkInitFailSuite + +eachHkInitFailSuite :: Suite +eachHkInitFailSuite = + [ PB.Hook + (NodePath "WebDriverDemo" "before once") + nothingOnceBefore [ PB.Hook (NodePath "WebDriverDemo" "before inner once") - pureErrorHook + pureOnceErrorHook [ PB.Hook (NodePath "WebDriverDemo" "each hook") eachHook - [Fixture (NodePath "WebDriverDemo" "test") fxLogMessage] + [Fixture (NodePath "WebDriverDemo" "fixture") $ fxLogMessage False] ] ] ] -eachHkFailDemo :: IO () -eachHkFailDemo = runIODemo eachHkFail +------------------------------------------------------ + +eachHkFailDemoNoRead :: IO () +eachHkFailDemoNoRead = runIODemo $ eachHkFail False --- $> eachHkFailDemo +--- $> eachHkFailDemoNoRead -- runs effect but does not throw error because test does not use hook input --- TODO - parameterise action with bool to use not use hook input -eachHkFail :: Suite -eachHkFail = + +------------------------------------------------------ + +eachHkFailDemoRead :: IO () +eachHkFailDemoRead = runIODemo $ eachHkFail True + +--- $> eachHkFailDemoRead +-- runs effect and throws error because test uses hook output +-- fails in the hook, not initialisation, because there is no caching of +-- the hook output in each hooks + +eachHkFail :: Bool -> Suite +eachHkFail readStatus = [ PB.Hook (NodePath "WebDriverDemo" "before once") - nothingBefore + nothingOnceBefore [ PB.Hook (NodePath "WebDriverDemo" "each hook Gunna Blow") eachFailureHook - [Fixture (NodePath "WebDriverDemo" "test") fxLogMessage] + [Fixture (NodePath "WebDriverDemo" "fixture") $ fxLogMessage readStatus] ] ] +------------------------------------------------------ +------------------------------------------------------ + config :: FixtureConfig config = FxCfg "test" DeepRegression -fxLogMessage :: Fixture DriverStatus -fxLogMessage = Full' config pureErrorHook action' parse items +fxLogMessage :: Bool -> Fixture DriverStatus +fxLogMessage readStatus = Full' config pureOnceErrorHook (action' readStatus) parse items --- Hook --- -nothingBefore :: PB.Hook Once Before () () -nothingBefore = +nothingOnceBefore :: PB.Hook Once Before () () +nothingOnceBefore = BeforeHook { action = \_rc -> do log "This is the outer hook" } -pureErrorHook :: PB.Hook Once Before () DriverStatus -pureErrorHook = +pureOnceErrorHook :: PB.Hook Once Before () DriverStatus +pureOnceErrorHook = BeforeHook' - { depends = nothingBefore, + { depends = nothingOnceBefore, action' = pureError "This is the inner hook" "BANG !!!! pureErrorHook Hook failed !!!" } +pureThreadErrorHook :: PB.Hook Once Before () DriverStatus +pureThreadErrorHook = + BeforeHook' + { depends = nothingOnceBefore, + action' = pureError "This is the Thread hook" "BANG !!!! pureThreadErrorHook Hook failed !!!" + } + eachHook :: PB.Hook Each Before DriverStatus DriverStatus eachHook = BeforeHook' - { depends = pureErrorHook, + { depends = pureOnceErrorHook, action' = \_rc ds -> do log "This is each hook" pure ds @@ -132,7 +176,7 @@ eachHook = eachFailureHook :: PB.Hook Each Before () DriverStatus eachFailureHook = BeforeHook' - { depends = nothingBefore, + { depends = nothingOnceBefore, action' = \_rc _ds -> do log "This is each hook" pure $ error "BANG !!!! eachFailureHook Hook failed !!!" @@ -143,8 +187,11 @@ pureError logMsg errMsg _rc _i = do log logMsg pure $ error errMsg -action' :: (Out NodeLog :> es) => RunConfig -> DriverStatus -> Data -> Eff es AS -action' _rc _hookDriverStatus itm = do +action' :: (Out NodeLog :> es) => Bool -> RunConfig -> DriverStatus -> Data -> Eff es AS +action' readStatus _rc hookDriverStatus itm = do + when readStatus $ + log $ "Reading status: " <> txt hookDriverStatus + log itm.title pure $ AS {status = Ready, checkButtonText = "Checkboxes"} @@ -182,7 +229,7 @@ items _rc = } ] --- ################### Simplified ################## +-- ################### Simplified Laziness (IO no test framework or effect system) ################## log_ :: Text -> IO () log_ = TIO.putStrLn From 282fbb5d00b3eb6e4a574d9a783970b660a2c104 Mon Sep 17 00:00:00 2001 From: theGhostJW Date: Mon, 7 Oct 2024 19:57:27 +0000 Subject: [PATCH 43/43] turn off demo --- examples/LazyinessSuiteDemo.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/LazyinessSuiteDemo.hs b/examples/LazyinessSuiteDemo.hs index 1d69f884..71df0535 100644 --- a/examples/LazyinessSuiteDemo.hs +++ b/examples/LazyinessSuiteDemo.hs @@ -55,7 +55,7 @@ onceHkDeferredSuite = ] ------------------------------------------------------ --- $> threadHkInitFailSuiteDemo +--- $> threadHkInitFailSuiteDemo -- creates an initialisation failure in each hook when thread hook output is cached threadHkInitFailSuiteDemo :: IO ()