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