symantic-http-test-0.0.1.20190410: Hspec/Utils.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hspec.Utils
 ( module Test.Hspec
 , module Test.Tasty
 , module Test.Tasty.Hspec
 , module Hspec.Utils
 , ($), (.)
 , Functor(..), (<$>)
 , Applicative(..)
 , Monad(..), (=<<)
 , Semigroup(..)
 , IO
 ) where

import Data.Bool
import Data.Eq (Eq(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), (=<<))
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import System.IO (IO)
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec
import Text.Show (Show(..), showString, showParen, ShowS)
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Test.Hspec.Wai as Wai

import Symantic.HTTP
import Symantic.HTTP.Server

instance (repr ~ Server) => Show (Router repr a b) where
	showsPrec p = \case
	 Router_Any{} -> showString "X"
	 Router_Map ms -> showParen (p>=10) $ showString "map [" . go (Map.toList ms) . showString "]"
		where
		go :: forall h k. [(PathSegment, Router repr h k)] -> ShowS
		go [] = id
		go ((n, r):xs) =
			(showParen True $ showString (show n<>", ") . showsPrec 0 r) .
			case xs of
			 [] -> id
			 _ -> showString ", " . go xs
	 Router_Seg s -> showsPrec 10 s
	 Router_Cat x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
	 Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
	 Router_Cap n -> showString (":"<>n)
	 Router_Union _u x -> showsPrec p x
	 Router_Caps cs -> showParen (p>=10) $ showString "cap [" . go cs . showString "]"
		where
		go :: Captures (Router repr) cs k -> ShowS
		go (Captures0 _a n r) = showParen True $ showString (":"<>n<>", ") . showsPrec 0 r
		go (Captures2 x y) = go x . showString ", " . go y

mkBody :: Wai.Body -> Wai.MatchBody
mkBody b = Wai.MatchBody $ \_ b' ->
	if b == b'
	then Nothing
	else Just $ TL.unpack $
	 "expecting: "<>TL.decodeUtf8 b<>
	 " but got: "<>TL.decodeUtf8 b'<>"\n"