servant-routes 0.1.0.0 → 0.1.1.0

raw patch · 27 files changed

+273/−69 lines, 27 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−1
• README.md +46/−17
• servant-routes.cabal +8/−1
• src/Servant/API/Routes.hs +20/−9
• src/Servant/API/Routes/Auth.hs +3/−3
• src/Servant/API/Routes/Header.hs +1/−1
• src/Servant/API/Routes/Internal/Auth.hs +1/−1
• src/Servant/API/Routes/Internal/Header.hs +1/−1
• src/Servant/API/Routes/Internal/Param.hs +3/−3
• src/Servant/API/Routes/Internal/Path.hs +1/−1
• src/Servant/API/Routes/Internal/Request.hs +1/−1
• src/Servant/API/Routes/Internal/Response.hs +2/−2
• src/Servant/API/Routes/Internal/Route.hs +42/−1
• src/Servant/API/Routes/Internal/Some.hs +2/−2
• src/Servant/API/Routes/Param.hs +2/−2
• src/Servant/API/Routes/Path.hs +3/−3
• src/Servant/API/Routes/Request.hs +3/−3
• src/Servant/API/Routes/Response.hs +3/−3
• src/Servant/API/Routes/Route.hs +10/−2
• src/Servant/API/Routes/Utils.hs +4/−4
• test/Servant/API/Routes/ParamSpec.hs +12/−0
• test/Servant/API/Routes/RequestSpec.hs +3/−1
• test/Servant/API/Routes/ResponseSpec.hs +5/−2
• test/Servant/API/Routes/RouteSpec.hs +12/−1
• test/Servant/API/Routes/SomeSpec.hs +2/−2
• test/Servant/API/Routes/Util.hs +27/−0
• test/Servant/API/RoutesSpec.hs +42/−2

@@ -7,6 +7,18 @@  ## [Unreleased] +## [0.1.1.0] - 10.06.2025++### Added++- A function to sort `Route`s before printing them to stdout. [#32](https://github.com/fpringle/servant-routes/pull/32)+- More GHC versions in `tested-with`.+- Add support for Servant's `Description` and `Summary` combinators. [#29](https://github.com/fpringle/servant-routes/pull/29)++### Fixed++- Bug in the hand-rolled `Ord Param` instance. [#34](https://github.com/fpringle/servant-routes/pull/34)+ ## [0.1.0.0] - 03.05.2025  ### Added@@ -17,5 +29,6 @@ - Reasonably detailed README. - CI that builds and tests the package for each version of GHC in the `tested-with` field. -[unreleased]: https://github.com/fpringle/servant-routes/compare/v0.1.0.0...HEAD+[unreleased]: https://github.com/fpringle/servant-routes/compare/v0.1.1.0...HEAD+[0.1.1.0]: https://github.com/fpringle/servant-routes/releases/tag/v0.1.1.0 [0.1.0.0]: https://github.com/fpringle/servant-routes/releases/tag/v0.1.0.0

@@ -1,6 +1,6 @@ # servant-routes -This package alllows us to automatically convert type-level Servant representations of APIs to concrete term-level representations.+This package allows us to automatically convert type-level Servant representations of APIs to concrete term-level representations.  See `Servant.API.Routes` for in-depth documentation. @@ -70,6 +70,7 @@ [     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/users/list",@@ -78,10 +79,12 @@         "response": {             "headers": [],             "type": "[User]"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "POST",         "params": [],         "path": "/users/create",@@ -90,10 +93,12 @@         "response": {             "headers": [],             "type": "UserID"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [             {@@ -113,10 +118,12 @@         "response": {             "headers": [],             "type": "User"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/transactions/<TransactionID>",@@ -130,12 +137,14 @@                 }             ],             "type": "Transaction"-        }+        },+        "summary": null     },     {         "auths": [             "Basic admin"         ],+        "description": null,         "method": "DELETE",         "params": [],         "path": "/admin/users/delete/<[UserID]>",@@ -144,7 +153,8 @@         "response": {             "headers": [],             "type": "UserID"-        }+        },+        "summary": null     } ] ```@@ -211,6 +221,7 @@ [     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/users/list",@@ -219,10 +230,12 @@         "response": {             "headers": [],             "type": "[User]"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "POST",         "params": [],         "path": "/users/create",@@ -231,10 +244,12 @@         "response": {             "headers": [],             "type": "UserID"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [             {@@ -254,10 +269,12 @@         "response": {             "headers": [],             "type": "User"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/transactions/<TransactionID>",@@ -271,12 +288,14 @@                 }             ],             "type": "Transaction"-        }+        },+        "summary": null     },     {         "auths": [             "Basic admin"         ],+        "description": null,         "method": "DELETE",         "params": [],         "path": "/admin/users/delete/<[UserID]>",@@ -285,10 +304,10 @@         "response": {             "headers": [],             "type": "UserID"-        }+        },+        "summary": null     } ]- ```  </details>@@ -334,6 +353,7 @@ [     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/users/list",@@ -347,10 +367,12 @@                 }             ],             "type": "[User]"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "POST",         "params": [],         "path": "/users/create",@@ -364,10 +386,12 @@                 }             ],             "type": "UserID"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [             {@@ -392,10 +416,12 @@                 }             ],             "type": "User"-        }+        },+        "summary": null     },     {         "auths": [],+        "description": null,         "method": "GET",         "params": [],         "path": "/transactions/<TransactionID>",@@ -413,12 +439,14 @@                 }             ],             "type": "Transaction"-        }+        },+        "summary": null     },     {         "auths": [             "Basic admin"         ],+        "description": null,         "method": "DELETE",         "params": [],         "path": "/admin/users/delete/<[UserID]>",@@ -432,7 +460,8 @@                 }             ],             "type": "UserID"-        }+        },+        "summary": null     } ] ```

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               servant-routes-version:            0.1.0.0+version:            0.1.1.0 synopsis:           Generate route descriptions from Servant APIs description:     See the documentation of 'Servant.API.Routes'.@@ -15,6 +15,7 @@ build-type:         Simple extra-doc-files:    CHANGELOG.md                     README.md+ tested-with:     GHC == 8.8.4   , GHC == 8.10.7@@ -23,10 +24,16 @@   , GHC == 9.2.8   , GHC == 9.4.2   , GHC == 9.4.5+  , GHC == 9.6.1+  , GHC == 9.6.7+  , GHC == 9.8.2+  , GHC == 9.10.2+  , GHC == 9.12.2  source-repository head   type:           git   location:       https://github.com/fpringle/servant-routes+  subdir:         servant-routes  common warnings   ghc-options: -Wall -Wno-unused-do-bind

@@ -6,7 +6,7 @@ Module      : Servant.API.Routes Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  This package provides two things: @@ -53,6 +53,7 @@     -- defining their own combinators.   , HasRoutes (..)   , printRoutes+  , printRoutesSorted   , printRoutesJSON   , printRoutesJSONPretty @@ -101,12 +102,14 @@   ) where +import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Encode.Pretty import qualified Data.Aeson.Key as AK (fromText) import qualified Data.Aeson.Types as A (Pair) import Data.Bifunctor (bimap) import Data.Foldable (foldl', traverse_)+import Data.List (sort) import qualified Data.Map as Map import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as T@@ -277,15 +280,23 @@   getRoutes :: [Route]  -- | Get all the routes of an API and print them to stdout. See 'renderRoute' for examples.-printRoutes :: forall api. HasRoutes api => IO ()+printRoutes :: forall api. (HasRoutes api) => IO () printRoutes = traverse_ printRoute $ getRoutes @api   where     printRoute = T.putStrLn . renderRoute +{- | Get all the routes of an API, sort them by path and method, and print them to stdout.+ See 'renderRoute' for examples.+-}+printRoutesSorted :: forall api. (HasRoutes api) => IO ()+printRoutesSorted = traverse_ printRoute . sort $ getRoutes @api+  where+    printRoute = T.putStrLn . renderRoute+ {- | Same as 'printRoutes`, but encode the t'Routes' as JSON before printing to stdout. For an even prettier version, see 'printRoutesJSONPretty'. -}-printRoutesJSON :: forall api. HasRoutes api => IO ()+printRoutesJSON :: forall api. (HasRoutes api) => IO () printRoutesJSON =   T.putStrLn     . TL.toStrict@@ -295,7 +306,7 @@     $ getRoutes @api  -- | Pretty-encode the t'Routes' as JSON before printing to stdout.-printRoutesJSONPretty :: forall api. HasRoutes api => IO ()+printRoutesJSONPretty :: forall api. (HasRoutes api) => IO () printRoutesJSONPretty =   T.putStrLn     . TL.toStrict@@ -308,7 +319,7 @@   getRoutes = mempty  instance-  ReflectMethod (method :: StdMethod) =>+  (ReflectMethod (method :: StdMethod)) =>   HasRoutes (NoContentVerb method)   where   getRoutes = pure $ defRoute method@@ -446,11 +457,11 @@     where       auth = basicAuth @realm -instance (HasRoutes api) => HasRoutes (Description sym :> api) where-  getRoutes = getRoutes @api+instance (HasRoutes api, KnownSymbol sym) => HasRoutes (Description sym :> api) where+  getRoutes = getRoutes @api <&> routeDescription %~ (<|> Just (RouteDescription (knownSymbolT @sym))) -instance (HasRoutes api) => HasRoutes (Summary sym :> api) where-  getRoutes = getRoutes @api+instance (HasRoutes api, KnownSymbol sym) => HasRoutes (Summary sym :> api) where+  getRoutes = getRoutes @api <&> routeSummary %~ (<|> Just (RouteSummary (knownSymbolT @sym)))  instance   (HasRoutes api, KnownSymbol tag) =>

@@ -4,7 +4,7 @@ Module      : Servant.API.Routes.Auth Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Here we define a very very basic type to represent authentication schemes. -}@@ -28,7 +28,7 @@ -} basicAuth ::   forall realm.-  KnownSymbol realm =>+  (KnownSymbol realm) =>   Auth basicAuth = Basic $ knownSymbolT @realm @@ -42,6 +42,6 @@ -} customAuth ::   forall tag.-  KnownSymbol tag =>+  (KnownSymbol tag) =>   Auth customAuth = Custom $ knownSymbolT @tag

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Header Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Simple representation of HTTP headers. -}

@@ -4,7 +4,7 @@ Module      : Servant.API.Routes.Internal.Auth Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}

@@ -4,7 +4,7 @@ Module      : Servant.API.Routes.Internal.Header Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}

@@ -4,7 +4,7 @@ Module      : Servant.API.Routes.Internal.Param Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}@@ -47,9 +47,9 @@       S.FlagParam name1 `comp` S.FlagParam name2 =         name1 `compare` name2       S.SingleParam {} `comp` _ = LT-      _ `comp` S.SingleParam {} = LT+      _ `comp` S.SingleParam {} = GT       S.ArrayElemParam {} `comp` _ = LT-      _ `comp` S.ArrayElemParam {} = LT+      _ `comp` S.ArrayElemParam {} = GT  data ParamType   = SingleParam

@@ -4,7 +4,7 @@ Module      : Servant.API.Routes.Internal.Path Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}

@@ -5,7 +5,7 @@ Module      : Servant.API.Routes.Internal.Request Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}

@@ -5,7 +5,7 @@ Module      : Servant.API.Routes.Internal.Response Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -}@@ -63,7 +63,7 @@ class HasResponse a where   getResponse :: Response -instance {-# OVERLAPPABLE #-} Typeable a => HasResponse a where+instance {-# OVERLAPPABLE #-} (Typeable a) => HasResponse a where   getResponse = Response (typeRepOf @a) mempty  instance {-# OVERLAPPING #-} (HasResponse a, GetHeaderReps hs) => HasResponse (Headers hs a) where

@@ -4,13 +4,15 @@ Module      : Servant.API.Routes.Internal.Route Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. -} module Servant.API.Routes.Internal.Route   ( -- * API routes     Route (..)+  , RouteDescription (..)+  , RouteSummary (..)      -- * Optics #optics#   , routeMethod@@ -20,12 +22,16 @@   , routeRequestBody   , routeResponse   , routeAuths+  , routeDescription+  , routeSummary   ) where  import Data.Aeson import Data.Function (on) import qualified Data.Set as Set+import Data.String (IsString)+import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Lens.Micro.TH import Network.HTTP.Types.Method (Method)@@ -36,6 +42,37 @@ import "this" Servant.API.Routes.Param import "this" Servant.API.Routes.Path +{- | Description of a route. This will correspond to the Servant @Description@ combinator.++It should  be noted that the 'HasRoutes' behaviour for @Description@ diverges from that in+@servant-openapi3@, in the case that one EP has multiple @Description@ combinators.+For example, given the following API:++@+type MyAPI =+  "transaction" :> TransactionAPI+    :\<|> "user" :> Description "User sub-API"+          :> ( Description "Get my user" :> Get '[JSON] User+              :\<|> "list" :> Get '[JSON] [User]+             )+@++The @Operation@ that @servant-openapi@ generates for the @GET /user@ endpoint will have the two+@Description@s 'mappend'-ed together: @"User sub-APIGet my user"@.++The corresponding 'Route' will take the most specific 'RouteDescription': @"Get my user"@.+-}+newtype RouteDescription = RouteDescription {unDescription :: T.Text}+  deriving (Show)+  deriving (Eq, IsString, Ord, Semigroup, Monoid, ToJSON, FromJSON) via T.Text++{- | Short summary of a route. This will correspond to the Servant @Summary@ combinator.+The behaviour described for 'RouteDescription' is the same for 'RouteSummary'.+-}+newtype RouteSummary = RouteSummary {unSummary :: T.Text}+  deriving (Show)+  deriving (Eq, IsString, Ord, Semigroup, Monoid, ToJSON, FromJSON) via T.Text+ -- | A simple representation of a single endpoint of an API. data Route = Route   { _routeMethod :: Method@@ -45,6 +82,8 @@   , _routeRequestBody :: Request   , _routeResponse :: Responses   , _routeAuths :: Set.Set Auth+  , _routeDescription :: Maybe RouteDescription+  , _routeSummary :: Maybe RouteSummary   }   deriving (Show, Eq) @@ -63,4 +102,6 @@       , "request_body" .= _routeRequestBody       , "response" .= _routeResponse       , "auths" .= _routeAuths+      , "description" .= _routeDescription+      , "summary" .= _routeSummary       ]

@@ -5,7 +5,7 @@ Module      : Servant.API.Routes.Internal.Some Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Internal module, subject to change. @@ -64,7 +64,7 @@  Use this to implement `Eq` instances for newtypes around 'Some'. -}-eqSome :: forall a. Eq a => ([a] -> [a] -> Bool) -> Some a -> Some a -> Bool+eqSome :: forall a. (Eq a) => ([a] -> [a] -> Bool) -> Some a -> Some a -> Bool eqSome eqList = eq   where     None `eq` None = True

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Param Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Simple representation of HTTP query params -}@@ -18,9 +18,9 @@ import qualified Data.Text as T import Data.Typeable import GHC.TypeLits+import qualified Servant.Links as S import "this" Servant.API.Routes.Internal.Param import "this" Servant.API.Routes.Utils-import qualified Servant.Links as S  -- | Create a 'S.SingleParam' from a 'Symbol' and a 'TypeRep' via 'Typeable'. singleParam :: forall s a. (KnownSymbol s, Typeable a) => Param

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Path Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Simple representation of URL paths. -}@@ -42,7 +42,7 @@ -} prependCapturePart ::   forall a.-  Typeable a =>+  (Typeable a) =>   T.Text ->   Path ->   Path@@ -58,7 +58,7 @@ -} prependCaptureAllPart ::   forall a.-  Typeable a =>+  (Typeable a) =>   T.Text ->   Path ->   Path

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Request Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Term-level representation of the request bodies that Servant endpoints expect. -}@@ -31,7 +31,7 @@ -} oneRequest ::   forall a.-  Typeable a =>+  (Typeable a) =>   Request oneRequest = Request . One $ typeRepOf @a @@ -40,7 +40,7 @@ -} allOfRequests ::   forall as.-  AllTypeable as =>+  (AllTypeable as) =>   Request allOfRequests = Request . Many $ typeReps @as 

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Response Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Term-level representation of the responses that Servant endpoints can return. -}@@ -32,7 +32,7 @@ -- | There is only one possible response. Equivalent to a single @'Servant.API.ReqBody' _ a@. oneResponse ::   forall a.-  HasResponse a =>+  (HasResponse a) =>   Responses oneResponse = Responses . One $ getResponse @a @@ -41,7 +41,7 @@ -} oneOfResponses ::   forall as.-  AllHasResponse as =>+  (AllHasResponse as) =>   Responses oneOfResponses = Responses . Many $ getResponses @as 

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Route Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Simple term-level representation of Servant API endpoints. -}@@ -24,7 +24,13 @@   , routeRequestBody   , routeResponse   , routeAuths+  , routeDescription+  , routeSummary   , add++    -- * Auxiliary types+  , RouteDescription (..)+  , RouteSummary (..)   ) where @@ -52,6 +58,8 @@     , _routeRequestBody = noRequest     , _routeResponse = noResponse     , _routeAuths = mempty+    , _routeDescription = Nothing+    , _routeSummary = Nothing     }  {- | Pretty-print a 'Route'. Note that the output is minimal and doesn't contain all the information@@ -83,5 +91,5 @@         then ""         else "?" <> T.intercalate "&" (renderParam <$> Set.toList _routeParams) -add :: Ord a => ASetter s t (Set.Set a) (Set.Set a) -> a -> s -> t+add :: (Ord a) => ASetter s t (Set.Set a) (Set.Set a) -> a -> s -> t add setter = over setter . Set.insert

@@ -2,7 +2,7 @@ Module      : Servant.API.Routes.Utils Copyright   : (c) Frederick Pringle, 2025 License     : BSD-3-Clause-Maintainer  : freddyjepringle@gmail.com+Maintainer  : frederick.pringle@fpringle.com  Common useful functions. -}@@ -21,7 +21,7 @@ import GHC.TypeLits  -- | Get the term-level equivalent of a 'Symbol' as a 'T.Text'.-knownSymbolT :: forall name. KnownSymbol name => T.Text+knownSymbolT :: forall name. (KnownSymbol name) => T.Text knownSymbolT = T.pack . symbolVal $ Proxy @name  -- | Convert a 'TypeRep' to a JSON 'Value' via its 'Show' instance.@@ -29,9 +29,9 @@ typeRepToJSON = toJSON . show @TypeRep  -- | Get the 'TypeRep' of a 'Typeable' type without having to mess around with 'Proxy'.-typeRepOf :: forall a. Typeable a => TypeRep+typeRepOf :: forall a. (Typeable a) => TypeRep typeRepOf = typeRep $ Proxy @a  -- | Get the 'TypeRep' of a 'Typeable' type as a 'T.Text'.-showTypeRep :: forall (a :: Type). Typeable a => T.Text+showTypeRep :: forall (a :: Type). (Typeable a) => T.Text showTypeRep = T.pack . show $ typeRepOf @a

@@ -2,7 +2,9 @@  import qualified Data.Text as T import Servant.API.Routes.Param+import Servant.API.Routes.Util import Test.Hspec as H+import qualified Test.QuickCheck as Q  sing, arrayElem, flag :: Param sing = singleParam @"sing_sym" @Int@@ -14,6 +16,12 @@ arrayElemExpected = "array_sym=<[Int]>" flagExpected = "flag_sym" +newtype ParamBasicQInstance = ParamBasicQInstance Param+  deriving (Show, Eq, Ord) via Param++instance Q.Arbitrary ParamBasicQInstance where+  arbitrary = ParamBasicQInstance <$> Q.elements [sing, arrayElem, flag]+ spec :: Spec spec = do   describe "renderParam" $ do@@ -23,3 +31,7 @@       renderParam arrayElem `shouldBe` arrayElemExpected     it "should render flagParam correctly" $ do       renderParam flag `shouldBe` flagExpected++  describe "Hand-rolled instances" $ do+    testEqInstances @ParamBasicQInstance+    testOrdInstances @ParamBasicQInstance

@@ -4,11 +4,11 @@ where  import Servant.API.Routes.Internal.Request-import "this" Servant.API.Routes.SomeSpec hiding (spec) import Servant.API.Routes.Util import Test.Hspec as H import Test.Hspec.QuickCheck as H import Test.QuickCheck as Q+import "this" Servant.API.Routes.SomeSpec hiding (spec)  {- hlint ignore "Monoid law, right identity" -} {- hlint ignore "Monoid law, left identity" -}@@ -31,3 +31,5 @@       \(xs :: [Request]) -> mconcat xs === foldr (<>) mempty xs   it "AllTypeable" $ do     typeReps @'[Int, String] `shouldMatchList` [intTypeRep, strTypeRep]+  describe "Hand-rolled instances" $ do+    testEqInstances @Request

@@ -4,13 +4,13 @@ where  import qualified Data.Set as Set-import "this" Servant.API.Routes.HeaderSpec (sampleReps) import Servant.API.Routes.Internal.Response-import "this" Servant.API.Routes.SomeSpec hiding (spec) import Servant.API.Routes.Util import Test.Hspec as H import Test.Hspec.QuickCheck as H import Test.QuickCheck as Q+import "this" Servant.API.Routes.HeaderSpec (sampleReps)+import "this" Servant.API.Routes.SomeSpec hiding (spec)  {- hlint ignore "Monoid law, right identity" -} {- hlint ignore "Monoid law, left identity" -}@@ -40,3 +40,6 @@       \(x :: Responses) -> mempty <> x === x     prop "Concatentation" $ do       \(xs :: [Responses]) -> mconcat xs === foldr (<>) mempty xs+  describe "Hand-rolled instances" $ do+    testEqInstances @Response+    testEqInstances @Responses

@@ -3,6 +3,7 @@   ) where +import Data.Coerce import Data.Function import qualified Data.Set as Set import qualified Data.Text as T@@ -17,6 +18,7 @@ import Servant.API.Routes.RequestSpec () import Servant.API.Routes.ResponseSpec () import Servant.API.Routes.Route+import Servant.API.Routes.Util import Test.Hspec as H import Test.QuickCheck as Q @@ -29,6 +31,8 @@     _routeRequestBody <- arbitrary     _routeResponse <- arbitrary     _routeAuths <- Set.fromList <$> Q.listOf genAuths+    _routeDescription <- Q.liftArbitrary genDescription+    _routeSummary <- Q.liftArbitrary genSummary      pure Route {..}     where@@ -37,6 +41,8 @@           [ Basic <$> genAlphaText           , Custom <$> genAlphaText           ]+      genDescription = RouteDescription . T.unwords <$> Q.listOf genAlphaText+      genSummary = RouteSummary . T.unwords <$> Q.scale (`div` 2) (Q.listOf genAlphaText)    shrink r =     routeMethod shrinkMethod r@@ -46,10 +52,12 @@       <> routeRequestBody Q.shrink r       <> routeResponse Q.shrink r       <> routeAuths (shrinkSet shrinkAuth) r+      <> routeDescription (Q.liftShrink (coerce shrinkText)) r+      <> routeSummary (Q.liftShrink (coerce shrinkText)) r     where       shrinkMethod = either (const []) (fmap renderStdMethod . Q.shrinkBoundedEnum) . parseMethod       shrinkSet shr = fmap Set.fromList . Q.shrinkList shr . Set.toList-      shrinkSubset :: Ord a => Set.Set a -> [Set.Set a]+      shrinkSubset :: (Ord a) => Set.Set a -> [Set.Set a]       shrinkSubset = shrinkSet (const [])       shrinkAuth = \case         Basic realm -> Basic <$> shrinkText realm@@ -74,3 +82,6 @@                 & routeParams .~ Set.fromList [sing, arrayElem, flag]             expected = "PUT /api/v2?" <> T.intercalate "&" [singExpected, arrayElemExpected, flagExpected]         in  renderRoute route `shouldBe` expected+  describe "Hand-rolled instances" $ do+    testEqInstances @ParamBasicQInstance+    testOrdInstances @ParamBasicQInstance

@@ -25,7 +25,7 @@ shrinkSome :: (a -> [a]) -> Some a -> [Some a] shrinkSome shr = fmap S.fromList . Q.shrinkList shr . S.toList -instance Q.Arbitrary a => Q.Arbitrary (Some a) where+instance (Q.Arbitrary a) => Q.Arbitrary (Some a) where   arbitrary = genSome arbitrary   shrink = shrinkSome shrink @@ -39,7 +39,7 @@   as <- Q.listOf gen   pure . AtLeast2 $ a1 : a2 : as -instance Arbitrary a => Arbitrary (AtLeast2 a) where+instance (Arbitrary a) => Arbitrary (AtLeast2 a) where   arbitrary = genAtLeast2 arbitrary   shrink = fmap AtLeast2 . filter ((>= 2) . length) . shrink . unAtLeast2 

@@ -1,6 +1,9 @@ module Servant.API.Routes.Util where  import Data.Typeable+import qualified Test.Hspec as H+import qualified Test.Hspec.QuickCheck as H+import qualified Test.QuickCheck as Q  intTypeRep :: TypeRep intTypeRep = typeRep $ Proxy @Int@@ -10,3 +13,27 @@  unitTypeRep :: TypeRep unitTypeRep = typeRep $ Proxy @()++{- HLINT ignore "Use /= -}++testEqInstances :: forall a. (Q.Arbitrary a, Show a, Eq a) => H.Spec+testEqInstances =+  H.describe "Eq instance should satisfy laws" $ do+    H.prop "Reflexivity" $ \(p1 :: a) ->+      p1 Q.=== p1+    H.prop "Symmetry" $ \(p1 :: a) p2 ->+      (p1 == p2) Q.=== (p2 == p1)+    H.prop "Negation" $ \(p1 :: a) p2 ->+      (p1 /= p2) Q.=== not (p1 == p2)++testOrdInstances :: forall a. (Q.Arbitrary a, Show a, Ord a) => H.Spec+testOrdInstances =+  H.describe "Ord instance should satisfy laws" $ do+    H.prop "Comparability" $ \(p1 :: a) p2 ->+      (p1 <= p2) Q..||. (p2 <= p1)+    H.prop "Transitivity" $ \(p1 :: a) p2 p3 ->+      (p1 <= p2 && p2 <= p3) Q.==> (p1 <= p3)+    H.prop "Reflexivity" $ \(p1 :: a) ->+      p1 <= p1+    H.prop "Antisymmetry" $ \(p1 :: a) p2 ->+      (p1 <= p2 && p2 <= p1) Q.==> (p1 Q.=== p2)

@@ -26,6 +26,22 @@  type SubAPI = ReqBody '[JSON] String :> Post '[JSON] Int +type DescriptionEP1 =+  "ep1" :> Description "This has a description" :> Get '[JSON] Int++type DescriptionEP2 =+  "ep2" :> Get '[JSON] String++type DescriptionAPI = DescriptionEP1 :<|> DescriptionEP2++type SummaryEP1 =+  "ep1" :> Summary "This has a description" :> Get '[JSON] Int++type SummaryEP2 =+  "ep2" :> Get '[JSON] String++type SummaryAPI = SummaryEP1 :<|> SummaryEP2+ type SubAPI2 = Header "h1" T.Text :> "x" :> ("y" :> Put '[JSON] String :<|> SubAPI)  type SubAPI3 =@@ -132,8 +148,6 @@         getRoutes @(Stream 'POST 201 NoFraming JSON Int) `shouldMatchList` [defRoute "POST" & routeResponse .~ intResponse]      describe "boring: combinators that don't change routes" $ do-      it "Description" $ unchanged @(Description "desc")-      it "Summary" $ unchanged @(Summary "summary")       it "Fragment" $ unchanged @(Fragment Int)       it "Vault" $ unchanged @Vault       it "HttpVersion" $ unchanged @HttpVersion@@ -145,6 +159,32 @@       it ":<|>" $ getRoutes @(SubAPI :<|> SubAPI2) `shouldMatchList` getRoutes @SubAPI <> getRoutes @SubAPI2       it "NoContentVerb" $         renderRoute <$> getRoutes @(NoContentVerb 'POST) `shouldMatchList` ["POST /"]+      describe "Description" $ do+        it "Should work as intended" $+          getRoutes @(Description "desc" :> SubAPI)+            `shouldMatchList` (getRoutes @SubAPI <&> routeDescription ?~ "desc")+        it "Should not override more specific descriptions" $+          getRoutes @(Description "desc1" :> Description "desc2" :> SubAPI)+            `shouldMatchList` getRoutes @(Description "desc2" :> SubAPI)+        it "Should set description for sub-routes without descriptions" $+          let epRoute1 = getRoutes @DescriptionEP1+              epRoute2 = getRoutes @DescriptionEP2+              withAddedDescRoutes = getRoutes @(Description "Overall" :> DescriptionAPI)+              expectedRoutes = epRoute1 <> (epRoute2 & traversed . routeDescription ?~ "Overall")+          in  withAddedDescRoutes `shouldMatchList` expectedRoutes+      describe "Summary" $ do+        it "Should work as intended" $+          getRoutes @(Summary "summ" :> SubAPI)+            `shouldMatchList` (getRoutes @SubAPI <&> routeSummary ?~ "summ")+        it "Should not override more specific summaries" $+          getRoutes @(Summary "summ1" :> Summary "summ2" :> SubAPI)+            `shouldMatchList` getRoutes @(Summary "summ2" :> SubAPI)+        it "Should set summary for sub-routes without summaries" $+          let epRoute1 = getRoutes @SummaryEP1+              epRoute2 = getRoutes @SummaryEP2+              withAddedSummRoutes = getRoutes @(Summary "Overall" :> SummaryAPI)+              expectedRoutes = epRoute1 <> (epRoute2 & traversed . routeSummary ?~ "Overall")+          in  withAddedSummRoutes `shouldMatchList` expectedRoutes       it "Symbol :>" $ do         let prep = routePath %~ prependPathPart "sym"         getRoutes @("sym" :> SubAPI) `shouldMatchList` prep <$> getRoutes @SubAPI