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