0 | module Evince.Hooks
  1 |
  2 | import Data.IORef
  3 | import Data.SnocList
  4 | import public Evince.Synchronized
  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 -> m (TestResult ())) -> b -> m (TestResult ())) -> SpecTree m a -> SpecTree m 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 -> m (TestResult ())) -> b -> m (TestResult ())) -> List (SpecTree m a) -> List (SpecTree m b)
 18 |   mapTrees f [] = []
 19 |   mapTrees f (t :: ts) = mapTree f t :: mapTrees f ts
 20 |
 21 | ||| Run an action before each test in the group.
 22 | export
 23 | before : Monad m => m () -> Spec m a () -> Spec m 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 action after each test in the group.
 29 | export
 30 | after : Monad m => m () -> Spec m a () -> Spec m 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 as a plain `m` action and must call it; teardown placed after that
 37 | ||| call runs whatever the test's result.
 38 | export
 39 | around : (m (TestResult ()) -> m (TestResult ())) -> Spec m a () -> Spec m a ()
 40 | around wrapper body =
 41 |   let trees = mapTrees (\test, res => wrapper (test res)) (getSpecTrees body)
 42 |   in MkSpec (Lin <>< trees) ()
 43 |
 44 | ||| Run an action once before the first test in the group.
 45 | ||| Subsequent tests reuse the cached result.
 46 | export
 47 | beforeAll : {m : Type -> Type} -> (Synchronized m, HasIO m) => m () -> Spec m a () -> Spec m a ()
 48 | beforeAll setup body =
 49 |   let ref  = unsafePerformIO (newIORef False)
 50 |       lock = unsafePerformIO newLock
 51 |       wrappedSetup = lock.withLock $ do
 52 |         done <- liftIO (readIORef ref)
 53 |         unless done $ do setup; liftIO (writeIORef ref True)
 54 |       trees = mapTrees (\test, res => wrappedSetup >> test res) (getSpecTrees body)
 55 |   in MkSpec (Lin <>< trees) ()
 56 |
 57 | ||| Run an action once after all tests in the group have finished.
 58 | export
 59 | afterAll : m () -> Spec m a () -> Spec m a ()
 60 | afterAll cleanup body =
 61 |   MkSpec [< WithCleanup cleanup (getSpecTrees body)] ()
 62 |
 63 | ||| Transform the resource type. Runs `f` before each test to produce the
 64 | ||| inner resource from the outer one.
 65 | export
 66 | beforeWith : Monad m => (outer -> m inner) -> Spec m inner () -> Spec m outer ()
 67 | beforeWith f body =
 68 |   let trees = mapTrees (\test, o => f o >>= test) (getSpecTrees body)
 69 |   in MkSpec (Lin <>< trees) ()
 70 |
 71 | ||| Most general hook: transform the resource type and wrap the test action,
 72 | ||| which the wrapper receives as a plain `m` action; teardown placed after
 73 | ||| calling it runs whatever the test's result.
 74 | export
 75 | aroundWith : ((inner -> m (TestResult ())) -> outer -> m (TestResult ())) -> Spec m inner () -> Spec m outer ()
 76 | aroundWith f body =
 77 |   let trees = mapTrees f (getSpecTrees body)
 78 |   in MkSpec (Lin <>< trees) ()
 79 |
 80 | ||| Run a cleanup action that has access to the resource after each test.
 81 | export
 82 | afterWith : Monad m => (a -> m ()) -> Spec m a () -> Spec m a ()
 83 | afterWith teardown body =
 84 |   let trees = mapTrees (\test, res => do r <- test res; teardown res; pure r) (getSpecTrees body)
 85 |   in MkSpec (Lin <>< trees) ()
 86 |
 87 | ||| Transform the resource type once for the entire group. Runs `f` once on
 88 | ||| the first test and caches the result for subsequent tests.
 89 | export
 90 | beforeAllWith : {m : Type -> Type} -> (Synchronized m, HasIO m) => (outer -> m inner) -> Spec m inner () -> Spec m outer ()
 91 | beforeAllWith f body =
 92 |   let ref  = unsafePerformIO (newIORef (the (Maybe inner) Nothing))
 93 |       lock = unsafePerformIO newLock
 94 |       cachedF = \o => lock.withLock $ do
 95 |         cached <- liftIO (readIORef ref)
 96 |         case cached of
 97 |           Just val => pure val
 98 |           Nothing => do val <- f o; liftIO (writeIORef ref (Just val)); pure val
 99 |       trees = mapTrees (\test, o => cachedF o >>= test) (getSpecTrees body)
100 |   in MkSpec (Lin <>< trees) ()
101 |
102 | ||| Convenience: produce a resource from nothing and thread it into tests.
103 | export
104 | provide : Monad m => m a -> Spec m a () -> Spec m () ()
105 | provide setup = beforeWith (\() => setup)
106 |