0 | module Evince.Hooks
  1 |
  2 | import Data.IORef
  3 | import Data.SnocList
  4 | import System.Concurrency
  5 | import Evince.Core
  6 |
  7 | -- Transform every It node's test action. Most general tree walker:
  8 | -- changes resource type and wraps the action in one pass.
  9 | mutual
 10 |   mapTree : ((a -> IO (TestResult ())) -> b -> IO (TestResult ())) -> SpecTree a -> SpecTree b
 11 |   mapTree f (It label loc test) = It label loc (f test)
 12 |   mapTree f (Describe label children) = Describe label (mapTrees f children)
 13 |   mapTree f (Focused t) = Focused (mapTree f t)
 14 |   mapTree f (WithCleanup cleanup children) = WithCleanup cleanup (mapTrees f children)
 15 |   mapTree f (Pending label reason) = Pending label reason
 16 |
 17 |   mapTrees : ((a -> IO (TestResult ())) -> b -> IO (TestResult ())) -> List (SpecTree a) -> List (SpecTree b)
 18 |   mapTrees f [] = []
 19 |   mapTrees f (t :: ts) = mapTree f t :: mapTrees f ts
 20 |
 21 | ||| Run an IO action before each test in the group.
 22 | export
 23 | before : IO () -> Spec a () -> Spec a ()
 24 | before setup body =
 25 |   let trees = mapTrees (\test, res => setup >> test res) (getSpecTrees body)
 26 |   in MkSpec (Lin <>< trees) ()
 27 |
 28 | ||| Run an IO action after each test in the group.
 29 | export
 30 | after : IO () -> Spec a () -> Spec a ()
 31 | after teardown body =
 32 |   let trees = mapTrees (\test, res => do r <- test res; teardown; pure r) (getSpecTrees body)
 33 |   in MkSpec (Lin <>< trees) ()
 34 |
 35 | ||| Wrap each test with a setup/teardown action. The wrapper receives the
 36 | ||| test action and must call it.
 37 | export
 38 | around : (IO (TestResult ()) -> IO (TestResult ())) -> Spec a () -> Spec a ()
 39 | around wrapper body =
 40 |   let trees = mapTrees (\test, res => wrapper (test res)) (getSpecTrees body)
 41 |   in MkSpec (Lin <>< trees) ()
 42 |
 43 | ||| Run an IO action once before the first test in the group.
 44 | ||| Subsequent tests reuse the cached result.
 45 | export
 46 | beforeAll : IO () -> Spec a () -> Spec a ()
 47 | beforeAll setup body =
 48 |   let ref = unsafePerformIO (newIORef False)
 49 |       mtx = unsafePerformIO makeMutex
 50 |       wrappedSetup = do
 51 |         mutexAcquire mtx
 52 |         done <- readIORef ref
 53 |         unless done $ do setup; writeIORef ref True
 54 |         mutexRelease mtx
 55 |       trees = mapTrees (\test, res => wrappedSetup >> test res) (getSpecTrees body)
 56 |   in MkSpec (Lin <>< trees) ()
 57 |
 58 | ||| Run an IO action once after all tests in the group have finished.
 59 | export
 60 | afterAll : IO () -> Spec a () -> Spec a ()
 61 | afterAll cleanup body =
 62 |   MkSpec [< WithCleanup cleanup (getSpecTrees body)] ()
 63 |
 64 | ||| Transform the resource type. Runs `f` before each test to produce the
 65 | ||| inner resource from the outer one.
 66 | export
 67 | beforeWith : (outer -> IO inner) -> Spec inner () -> Spec outer ()
 68 | beforeWith f body =
 69 |   let trees = mapTrees (\test, o => f o >>= test) (getSpecTrees body)
 70 |   in MkSpec (Lin <>< trees) ()
 71 |
 72 | ||| Most general hook: transform both the resource type and wrap the test action.
 73 | export
 74 | aroundWith : ((inner -> IO (TestResult ())) -> outer -> IO (TestResult ())) -> Spec inner () -> Spec outer ()
 75 | aroundWith f body =
 76 |   let trees = mapTrees f (getSpecTrees body)
 77 |   in MkSpec (Lin <>< trees) ()
 78 |
 79 | ||| Run a cleanup action that has access to the resource after each test.
 80 | export
 81 | afterWith : (a -> IO ()) -> Spec a () -> Spec a ()
 82 | afterWith teardown body =
 83 |   let trees = mapTrees (\test, res => do r <- test res; teardown res; pure r) (getSpecTrees body)
 84 |   in MkSpec (Lin <>< trees) ()
 85 |
 86 | ||| Transform the resource type once for the entire group. Runs `f` once on
 87 | ||| the first test and caches the result for subsequent tests.
 88 | export
 89 | beforeAllWith : (outer -> IO inner) -> Spec inner () -> Spec outer ()
 90 | beforeAllWith f body =
 91 |   let ref : IORef (Maybe inner) = unsafePerformIO (newIORef Nothing)
 92 |       mtx = unsafePerformIO makeMutex
 93 |       cachedF = \o => do
 94 |         mutexAcquire mtx
 95 |         cached <- readIORef ref
 96 |         val <- case cached of
 97 |           Just val => pure val
 98 |           Nothing => do val <- f o; writeIORef ref (Just val); pure val
 99 |         mutexRelease mtx
100 |         pure val
101 |       trees = mapTrees (\test, o => cachedF o >>= test) (getSpecTrees body)
102 |   in MkSpec (Lin <>< trees) ()
103 |
104 | ||| Convenience: produce a resource from nothing and thread it into tests.
105 | export
106 | provide : IO a -> Spec a () -> Spec () ()
107 | provide setup = beforeWith (\() => setup)
108 |