@@ -1,28 +1,42 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE TypeSynonymInstances #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE TypeSynonymInstances #-}
912{-# OPTIONS_GHC -fno-warn-orphans #-}
1013{-# OPTIONS_GHC -freduction-depth=100 #-}
1114
1215module Servant.DocsSpec where
1316
1417import Control.Lens
18+import Control.Monad
19+ (unless)
20+import Control.Monad.Trans.Writer
21+ (Writer, runWriter, tell)
1522import Data.Aeson
23+import Data.List
24+ (isInfixOf)
1625import Data.Monoid
1726import Data.Proxy
1827import Data.String.Conversions
1928 (cs)
2029import GHC.Generics
21−import Test.Hspec
30+import Prelude ()
31+import Prelude.Compat
32+import Test.Tasty
33+ (TestName, TestTree, testGroup)
34+import Test.Tasty.HUnit
35+ (Assertion, HasCallStack, assertFailure, testCase, (@?=))
2236
2337import Servant.API
24−import Servant.Test.ComprehensiveAPI
2538import Servant.Docs.Internal
39+import Servant.Test.ComprehensiveAPI
2640
2741-- * comprehensive api
2842
@@ -44,7 +58,7 @@ instance ToCapture (CaptureAll "foo" Int) where
4458
4559-- * specs
4660
47−spec :: Spec
61+spec :: TestTree
4862spec = describe "Servant.Docs" $ do
4963
5064 describe "markdown" $ do
@@ -146,3 +160,38 @@ instance ToSample TT where
146160
147161instance ToSample UT where
148162 toSamples _ = [("yks", UT1), ("kaks", UT2)]
163+
164+-------------------------------------------------------------------------------
165+-- HSpec like DSL for tasty
166+-------------------------------------------------------------------------------
167+
168+newtype TestTreeM a = TestTreeM (Writer [TestTree] a)
169+ deriving (Functor, Applicative, Monad)
170+
171+runTestTreeM :: TestTreeM () -> [TestTree]
172+runTestTreeM (TestTreeM m) = snd (runWriter m)
173+
174+class Describe r where
175+ describe :: TestName -> TestTreeM () -> r
176+
177+instance a ~ () => Describe (TestTreeM a) where
178+ describe n t = TestTreeM $ tell [ describe n t ]
179+
180+instance Describe TestTree where
181+ describe n t = testGroup n $ runTestTreeM t
182+
183+it :: TestName -> Assertion -> TestTreeM ()
184+it n assertion = TestTreeM $ tell [ testCase n assertion ]
185+
186+shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion
187+shouldBe = (@?=)
188+
189+shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
190+shouldContain = compareWith (flip isInfixOf) "does not contain"
191+
192+shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
193+shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains"
194+
195+compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion
196+compareWith f msg x y = unless (f x y) $ assertFailure $
197+ show x ++ " " ++ msg ++ " " ++ show y