TestGADT.hs

{-# 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!

-}