]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-test/Hspec/Utils.hs
2bf1ad9cacf6f1ca14f2af4aaeb2ce427ffd973a
[haskell/symantic-http.git] / symantic-http-test / Hspec / Utils.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# OPTIONS_GHC -Wno-orphans #-}
3 module Hspec.Utils
4 ( module Test.Hspec
5 , module Test.Tasty
6 , module Test.Tasty.Hspec
7 , module Hspec.Utils
8 , ($), (.)
9 , Functor(..), (<$>)
10 , Applicative(..)
11 , Monad(..), (=<<)
12 , Semigroup(..)
13 , IO
14 ) where
15
16 import Data.Bool
17 import Data.Eq (Eq(..))
18 import Data.Maybe (Maybe(..))
19 import Data.Ord (Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import Control.Applicative (Applicative(..))
22 import Control.Monad (Monad(..), (=<<))
23 import Data.Function (($), (.), id)
24 import Data.Functor (Functor(..), (<$>))
25 import System.IO (IO)
26 import Test.Hspec
27 import Test.Tasty
28 import Test.Tasty.Hspec
29 import Text.Show (Show(..), showString, showParen, ShowS)
30 import qualified Data.Map.Strict as Map
31 import qualified Data.Text.Lazy as TL
32 import qualified Data.Text.Lazy.Encoding as TL
33 import qualified Test.Hspec.Wai as Wai
34
35 import Symantic.HTTP
36 import Symantic.HTTP.Server
37
38 instance (repr ~ Server) => Show (Router repr a b) where
39 showsPrec p = \case
40 Router_Any{} -> showString "X"
41 Router_Map ms -> showParen (p>=10) $ showString "map [" . go (Map.toList ms) . showString "]"
42 where
43 go :: forall h k. [(PathSegment, Router repr h k)] -> ShowS
44 go [] = id
45 go ((n, r):xs) =
46 (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
47 case xs of
48 [] -> id
49 _ -> showString ", " . go xs
50 Router_Seg s -> showsPrec 10 s
51 Router_Cat x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
52 Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
53 Router_Cap n -> showString (":"<>n)
54 Router_Union _u x -> showsPrec p x
55 Router_Caps cs -> showParen (p>=10) $ showString "cap [" . go cs . showString "]"
56 where
57 go :: Captures (Router repr) cs k -> ShowS
58 go (Captures0 _a n r) = showParen True $ showString (":"<>n<>", ") . showsPrec 0 r
59 go (Captures2 x y) = go x . showString ", " . go y
60
61 mkBody :: Wai.Body -> Wai.MatchBody
62 mkBody b = Wai.MatchBody $ \_ b' ->
63 if b == b'
64 then Nothing
65 else Just $ TL.unpack $
66 "expecting: "<>TL.decodeUtf8 b<>
67 " but got: "<>TL.decodeUtf8 b'<>"\n"
68