Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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