{-# LANGUAGE DeriveFunctor, GADTs #-} | |
import Control.Monad.Writer | |
import Data.List (intercalate) | |
import Data.Foldable (traverse_) | |
data S m a where | |
It :: String -> m a -> S m a | |
Describe :: String -> S m a -> S m a | |
Group :: [S m a] -> S m a | |
BeforeEach :: m a -> S m (a -> b) -> S m b | |
BeforeAll :: m a -> S m (a -> b) -> S m b | |
instance Functor m => Functor (S m) where | |
fmap f (It name action) = It name (fmap f action) | |
fmap f (Describe name spec) = Describe name (fmap f spec) | |
fmap f (Group groups) = Group (map (fmap f) groups) | |
fmap f (BeforeEach setup spec) = BeforeEach setup (fmap (f .) spec) | |
fmap f (BeforeAll setup spec) = BeforeEach setup (fmap (f .) spec) | |
-- stripped <*> | |
pushS :: Applicative m => m a -> S m (a -> b) -> S m b | |
pushS s (It name action) = It name (flip id <$> s <*> action) | |
pushS s (Describe name spec) = Describe name (pushS s spec) | |
pushS s (Group groups) = Group (map (pushS s) groups) | |
pushS s (BeforeEach setup spec) = Group [pushS s (pushS setup spec)] | |
pushS s (BeforeAll setup spec) = BeforeAll setup (pushS s (fmap flip spec)) | |
type Spec m a = Writer [S m a] () | |
it :: Monad m => String -> a -> Spec m a | |
it name body = tell [It name (return body)] | |
describe :: String -> Spec m a -> Spec m a | |
describe name spec = do | |
let groups = execWriter spec | |
tell [Describe name (Group groups)] | |
beforeEach :: m a -> Spec m (a -> b) -> Spec m b | |
beforeEach setup spec = do | |
let groups = execWriter spec | |
tell [BeforeEach setup (Group groups)] | |
beforeAll :: m a -> Spec m (a -> b) -> Spec m b | |
beforeAll setup spec = do | |
let groups = execWriter spec | |
tell [BeforeAll setup (Group groups)] | |
run :: Spec IO (IO ()) -> IO () | |
run = void . goMany [] . execWriter | |
where | |
goMany :: [String] -> [S IO a] -> IO () | |
goMany ctx = traverse_ (go ctx) | |
go :: [String] -> S IO a -> IO () | |
go ctx (It name body) = do | |
let heading = intercalate " > " ctx ++ " > it " ++ name | |
putStrLn heading | |
void body | |
go ctx (Group groups) = goMany ctx groups | |
go ctx (Describe name spec) = go (ctx ++ [name]) spec | |
-- Run setup once | |
go ctx (BeforeAll setup spec) = do | |
x <- setup | |
go ctx (fmap ($x) spec) | |
-- Push setup into each S | |
go ctx (BeforeEach setup spec) = | |
go ctx (pushS setup spec) | |
tree :: Spec m a -> IO () | |
tree = goMany [] . execWriter | |
where | |
goMany :: [String] -> [S m a] -> IO () | |
goMany ctx = traverse_ (go ctx) | |
go :: [String] -> S m a -> IO () | |
go ctx (It name _) = putStrLn $ intercalate " > " ctx ++ " > it" ++ name | |
go ctx (Describe name spec) = go (ctx ++ [name]) spec | |
go ctx (Group spec) = goMany ctx spec | |
go ctx (BeforeAll _ spec) = go ctx spec | |
go ctx (BeforeEach _ spec) = go ctx spec | |
------------------------------------------------------------------------------- | |
-- Example | |
------------------------------------------------------------------------------- | |
mySpec :: Spec IO (IO ()) | |
mySpec = | |
beforeAll (putStrLn "once, before all!" >> return "foo") $ do | |
describe "module 1" $ | |
beforeEach (putStrLn "before each 1!" >> r 20) $ | |
describe "feature A" $ do | |
it "works!" (\x _y -> assert (x == 20)) | |
it "works again!" (\_x y -> assert (y == "foo")) | |
describe "module 2" $ | |
beforeEach (putStrLn "before each 2!" >> r 30) $ | |
describe "feature B" $ do | |
it "works!" (\x _y -> assert (x == 30)) | |
it "works again!" (\_x y -> assert (y == "foo")) | |
where | |
r :: Monad m => Int -> m Int | |
r = return | |
assert :: Bool -> IO () | |
assert True = return () | |
assert False = fail "Test failure!" | |
main :: IO () | |
main = do | |
tree mySpec | |
putStrLn "---- Run ----" | |
run mySpec | |
{- | |
module 1 > feature A > itworks! | |
module 1 > feature A > itworks again! | |
module 2 > feature B > itworks! | |
module 2 > feature B > itworks again! | |
---- Run ---- | |
once, before all! | |
module 1 > feature A > it works! | |
before each 1! | |
module 1 > feature A > it works again! | |
before each 1! | |
module 2 > feature B > it works! | |
before each 2! | |
module 2 > feature B > it works again! | |
before each 2! | |
-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment