Merge pull request #14 from theGhostJW:documentation-poc

Documentation-poc
theGhostJW · Oct 7, 2024 · 4a96441 · 4a96441
2 parents ab687ac + 282fbb5
commit 4a96441
Show file tree

Hide file tree

Showing 35 changed files with 1,482 additions and 842 deletions.
diff --git 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/DocumenterDemo.hs b/examples/DocumenterDemo.hs
@@ -1,70 +1,64 @@
 module DocumenterDemo where
 
-import DSL.Internal.NodeEvent (NodeEvent (User), UserLog (Log))
-import DSL.Out (Out, out)
+import Check
+import Core (Before, Once, ParseException)
+import DSL.FileSystemEffect
+import DSL.Internal.NodeLog (NodeLog, Path (NodePath))
+import DSL.Logging ( log )
+import DSL.OutEffect (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/"
-
-_checkBoxesLinkCss :: Selector
-_checkBoxesLinkCss = CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)"
+import Internal.SuiteRuntime (ThreadCount (..))
+import Path as P (Path, reldir, toFilePath)
+import PyrethrumBase
+  ( DataSource (..),
+    Depth (..),
+    Fixture (..),
+    FixtureConfig (..),
+    Hook (..),
+    Node (..),
+    RunConfig (..),
+    Suite,
+    SuiteRunner,
+    defaultRunConfig,
+    docRunner,
+  )
+import PyrethrumExtras (Abs, File, relfile, toS, txt, (?))
+import WebDriverEffect
+  ( WebUI,
+    clickElem,
+    findElem,
+    go,
+    killSession,
+    maximiseWindow,
+    newSession,
+    readElem,
+    sleep,
+  )
+import WebDriverPure (seconds)
+import WebDriverSpec (DriverStatus (..), Selector (CSS))
 
 runDemo :: SuiteRunner -> Suite -> IO ()
-runDemo runner suite = do 
-  (logControls, _logQ) <- L.testLogControls True
+runDemo runner suite = do
+  (logControls, _logList) <- L.testLogActions True
   runner suite Unfiltered defaultRunConfig (ThreadCount 1) logControls
 
--- ############### Test Case ###################
-
--- TODO: repeated code - refactor
-logShow :: (HasLog es, Show a) => a -> Eff es ()
-logShow = out . User . Log . txt
+-- putStrLn "########## Log ##########"
+-- atomically logList >>= mapM_ pPrint
 
-log :: (HasLog es) => Text -> Eff es ()
-log = out . User . Log
+docDemo :: Bool -> Bool -> Suite -> IO ()
+docDemo stp chks = runDemo $ docRunner stp chks
 
+-- ############### Test Case ###################
 
 -- 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"
@@ -78,61 +72,179 @@ 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 ()
 
-fsDemoAp :: forall es. (FSOut es) => Eff es ()
+fsDemoAp :: forall es. (Out NodeLog :> 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
+
+-- ################### 1. FS App with full runtime ##################
+
+fsSuiteDemo :: IO ()
+fsSuiteDemo = docDemo True True fsSuite
+
+-- >>> fsSuiteDemo
 
-fsDocDemoSimple :: IO ()
-fsDocDemoSimple = 
-  --  docInterpreter fsDemoAp
-  docRun fsDemoAp
-  where 
-    docRun :: Eff '[FileSystem, Out NodeEvent, IOE] a -> IO a
-    docRun = runEff . runDocOut . FDoc.runFileSystem
--- >>> fsDocDemoSimple
+-- TODO: fix filter log
+fsSuite :: Suite
+fsSuite =
+  [Fixture (NodePath "FS Demo Test" "test") fstest]
+
+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 = error "This is an error !!! "
+
+fsAction :: (FileSystem :> es, Out NodeLog :> es) => RunConfig -> FSData -> Eff es FSAS
+fsAction _rc i = do
+  getFailNested
+  -- getFail
+  paths <- getPaths
+  log i.title
+  chkPathsThatDoesNothing paths
+  log "Paths checked ~ not really"
+  pure $ FSAS {paths}
 
-{- TODO: make documenter work with this (copy of Webdriver demo)
+data FSData = FSItem
+  { id :: Int,
+    title :: Text,
+    checks :: Checks FSDS
+  }
+  deriving (Show, Read)
+
+{-
+TODO: make better 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 ##################
+
+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
+
+titlesWebdriverDemo :: IO ()
+titlesWebdriverDemo = baseWdDemo False False
+
+-- >>> titlesWebdriverDemo
+
+-- 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
+          ]
+      ]
+  ]
+
+
+--- Hook ---
+
+nothingBefore :: Hook Once Before () ()
+nothingBefore =
+  BeforeHook
+    { action = \_rc -> do
+        log "This is the outer hook"
+        log "Run once before the 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
+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 Int
+test = Full' config intOnceHook action parse items
 
 config :: FixtureConfig
 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
-  pure status
+-- driver_status :: (WebUI :> es) => Eff es DriverStatus
+driver_status :: Eff es DriverStatus
+driver_status = pure $ error "This is a lazy error !!!"
+-- driver_status = driverStatus
 
-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 _rc i = do
-  log i.title
+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 $ "the driver status is: " <> txt status
+  log "GOT DRIVER 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
@@ -175,5 +287,3 @@ items _rc =
               <> chk "Checkboxes text as expected" ((== "Checkboxes") . (.checkButtonText))
         }
     ]
-
--}