d54960d · roboservant · git.iko.soy

git.iko.soy/roboservant

type-safe servant interface

commitd54960dcecad4c15da63153c4e33731b425c1021 authorJustin Le <justin@jle.im> dateTue 17 Nov 2020, 14:14 (6 years ago) parentc9076d7

7 files changed+268−124

compare with master

unifiedsplit

package.yaml+4 roboservant.cabal+9−1 src/Roboservant/Direct.hs+100−56 src/Roboservant/Types/Breakdown.hs+30−11 src/Roboservant/Types/ReifiedApi.hs+93−56 stack.yaml+4 stack.yaml.lock+28

package.yaml+4

@@ -27,6 +27,10 @@ dependencies:

2727- servant-flatten

2828- servant-server # >= 0.17

2929- string-conversions

30+- vinyl

31+- dependent-sum

32+- dependent-map

33+- text

3034

3135ghc-options:

3236- -Wall

roboservant.cabal+9−1

@@ -4,7 +4,7 @@ cabal-version: 1.12

44--

55-- see: https://github.com/sol/hpack

66--

7−-- hash: 8359b70b81d2fdfc7001a1f607745da953f6e8f7b8188a54857d658406c238a2

7+-- hash: d9b75d0543bde313d954ce10fe6c45bbb21467e7c2d65320dc3a85e15a6ec345

99name: roboservant

1010version: 0.1.0.2

@@ -44,6 +44,8 @@ library

4444 base >=4.7 && <5

4545 , bytestring

4646 , containers

47+ , dependent-map

48+ , dependent-sum

4749 , lifted-base

4850 , monad-control

4951 , mtl

@@ -53,6 +55,8 @@ library

5355 , servant-flatten

5456 , servant-server

5557 , string-conversions

58+ , text

59+ , vinyl

5660 default-language: Haskell2010

5761

5862test-suite roboservant-test

@@ -73,6 +77,8 @@ test-suite roboservant-test

7377 , base >=4.7 && <5

7478 , bytestring

7579 , containers

80+ , dependent-map

81+ , dependent-sum

7682 , hspec

7783 , hspec-core

7884 , lifted-base

@@ -85,4 +91,6 @@ test-suite roboservant-test

8591 , servant-flatten

8692 , servant-server

8793 , string-conversions

94+ , text

95+ , vinyl

8896 default-language: Haskell2010

src/Roboservant/Direct.hs+100−56

@@ -7,6 +7,7 @@

77{-# LANGUAGE GeneralizedNewtypeDeriving #-}

88{-# LANGUAGE LambdaCase #-}

99{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

1011{-# LANGUAGE RecordWildCards #-}

1112{-# LANGUAGE ScopedTypeVariables #-}

1213{-# LANGUAGE StandaloneDeriving #-}

@@ -22,18 +23,26 @@ module Roboservant.Direct

2223where

2324

2425import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)

25−import Control.Monad(void,replicateM)

26+import Control.Monad(void,replicateM,forM_)

2627import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)

2728import Control.Monad.Trans.Control(MonadBaseControl)

28−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)

29+import Data.Dependent.Map (DMap)

30+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)

31+import Data.List.NonEmpty (NonEmpty(..))

2932import Data.Map.Strict(Map)

3033import Data.Maybe (mapMaybe)

3134import Data.Typeable (TypeRep)

3235import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))

3336import System.Random(StdGen,randomR,mkStdGen)

3437import System.Timeout.Lifted(timeout)

38+import GHC.Generics ((:*:)(..))

39+import qualified Data.Vinyl.Functor as V

40+import qualified Data.Vinyl.Curry as V

41+import qualified Data.Dependent.Map as DM

42+import qualified Data.Vinyl as V

3543import qualified Data.List.NonEmpty as NEL

3644import qualified Data.Map.Strict as Map

45+import qualified Type.Reflection as R

3746

3847import Roboservant.Types.Breakdown

3948import Roboservant.Types

@@ -41,6 +50,10 @@ import Roboservant.Types

4150 FlattenServer (..),

4251-- ReifiedApi,

4352 ToReifiedApi (..),

53+ ReifiedEndpoint(..),

54+ Argument(..),

55+ TypedF

56+

4457 )

4558

4659data RoboservantException

@@ -72,7 +85,12 @@ data FuzzState = FuzzState

7285 , stash :: Stash

7386 , currentRng :: StdGen

7487 }

75− deriving (Show)

88+ deriving Show

89+

90+data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption

91+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

92+ , eoArgs :: V.Rec (TypedF StashValue) as

93+ }

7694

7795fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))

7896 => Server api

@@ -87,8 +105,11 @@ fuzz server Config{..} checker = do

87105 -- and throw an exception that propagates through this.

88106

89107 void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})

90− mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi

91−

108+ forM_ reifiedApi $ \(offset, ReifiedEndpoint{..}) ->

109+ print (

110+ offset

111+ , recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) reArguments

112+ )

92113 where

93114

94115 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

@@ -102,67 +123,77 @@ fuzz server Config{..} checker = do

102123 modify' $ \st' -> st' { currentRng = newGen }

103124 pure (l !! index)

104125

105− genOp :: (MonadState FuzzState m, MonadIO m)

106− => m (FuzzOp, Dynamic, [Dynamic])

107− genOp = do -- fs@FuzzState{..} = do

126+ withOp :: (MonadState FuzzState m, MonadIO m)

127+ => (forall as. (V.RecordToList as, V.RMap as)

128+ => FuzzOp

129+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

130+ -> V.Rec (TypedF V.Identity) as -> m r

131+ )

132+ -> m r

133+ withOp callback = do

108134 -- choose a call to make, from the endpoints with fillable arguments.

109− (offset, dynCall, args) <- elementOrFail . options =<< get

110− r <- mapM (elementOrFail . zip [0..] . NEL.toList) args

111− let pathSegment = FuzzOp offset (map (\(index,(_,dyn) ) -> Provenance (dynTypeRep dyn) index) r)

135+ (offset, EndpointOption{..}) <- elementOrFail . options =<< get

136+ r <- V.rtraverse

137+ (\(tr :*: StashValue svs) -> elementOrFail $

138+ zipWith (\i xy -> V.Const i :*: tr :*: xy)

139+ [0..]

140+ (NEL.toList svs)

141+ )

142+ eoArgs

143+ let pathSegment = FuzzOp offset $

144+ recordToList'

145+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)

146+ r

147+ argValues = V.rmap

148+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)

149+ r

112150 modify' (\f -> f { path = path f <> [pathSegment] })

113− pure (pathSegment, dynCall, fmap (snd . snd) r)

114−

151+ callback pathSegment eoCall argValues

115152 where

116− options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]

153+ options :: FuzzState -> [(ApiOffset, EndpointOption)]

117154 options FuzzState{..} =

118155 mapMaybe

119− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do

120− mapM (\(_tr,bf) -> bf stash ) argreps

156+ ( \(offset, ReifiedEndpoint{..}) -> do

157+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments

158+ pure (offset, EndpointOption reEndpointFunc args)

121159 )

122160 reifiedApi

123161

124− execute :: (MonadState FuzzState m, MonadIO m)

125− => (FuzzOp,Dynamic,[Dynamic]) -> m ()

126− execute (fuzzop, dyncall, args) = do

162+ execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)

163+ => FuzzOp

164+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

165+ -> V.Rec (TypedF V.Identity) as

166+ -> m ()

167+ execute fuzzop func args = do

127168 liftIO $ print fuzzop

128− -- now, magic happens: we apply some dynamic arguments to a dynamic

129− -- function and hopefully something useful pops out the end.

130− let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)

131169 st <- get

132− let showable = unlines $ ("args":map (show . dynTypeRep) args)

170+ let showable = unlines $ ("args":map show argTypes)

133171 <> ["fuzzop"

134172 , show fuzzop

135− ,"dyncall"

136− ,show (dynTypeRep dyncall)

173+ -- ,"dyncall"

174+ -- ,show (dynTypeRep dyncall)

137175 ,"state"

138176 ,show st]

139177 liftIO $ putStrLn showable

140−

141− case func of

142− Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

143− Just (f') -> do

144− -- liftIO $ print

145− case fromDynamic f' of

146− Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

147− Just (f) -> liftIO f >>= \case

148− -- parameterise this

149− Left (serverError :: ServerError) ->

150− case errHTTPCode serverError of

151− 500 -> throw serverError

152− _ -> do

153− liftIO $ print ("ignoring non-500 error" , serverError)

154−

155− Right (dyn :: NEL.NonEmpty Dynamic) -> do

156− liftIO $ print ("storing", fmap dynTypeRep dyn)

157− modify' (\fs@FuzzState{..} ->

158− fs { stash = addToStash (NEL.toList dyn) stash } )

159− pure ()

178+ liftIO (V.runcurry' func argVals) >>= \case

179+ -- parameterise this

180+ Left (serverError :: ServerError) ->

181+ case errHTTPCode serverError of

182+ 500 -> throw serverError

183+ _ -> do

184+ liftIO $ print ("ignoring non-500 error" , serverError)

185+ Right (dyn :: NEL.NonEmpty Dynamic) -> do

186+ liftIO $ print ("storing", fmap dynTypeRep dyn)

187+ modify' (\fs@FuzzState{..} ->

188+ fs { stash = addToStash (NEL.toList dyn) stash } )

189+ where

190+ argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

191+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

160192

161193 go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)

162194 => m ()

163− go = do

164− op <- genOp

165− catches (execute op)

195+ go = withOp $ \op func args -> do

196+ catches (execute op func args)

166197 [ Handler (\(e :: SomeAsyncException) -> throw e)

167198 , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)

168199 ]

@@ -177,17 +208,30 @@ fuzz server Config{..} checker = do

177208 -- (fmap preload seed <> [callEndpoint reifiedApi])

178209 -- executeSequential emptyState actions

179210addToStash :: [Dynamic]

180− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))

181− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))

211+ -> Stash

212+ -> Stash

182213addToStash result stash =

183− foldr (\dyn dict -> let tr = dynTypeRep dyn in

184− Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result

214+ foldr (\(Dynamic tr x) (Stash dict) -> Stash $

215+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict

216+ -- in DM.insertWith renumber _ (pure ([Provenance tr 0],x)) dict

217+ )

218+ stash

219+ result

185220-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })

186221 where

187− renumber :: NEL.NonEmpty ([Provenance],Dynamic)

188− -> NEL.NonEmpty ([Provenance],Dynamic)

189− -> NEL.NonEmpty ([Provenance],Dynamic)

190− renumber singleDyn l = case NEL.toList singleDyn of

222+ renumber :: StashValue a

223+ -> StashValue a

224+ -> StashValue a

225+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of

191226 [([Provenance tr _], dyn)] -> l

192227 <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

193228 _ -> error "should be impossible"

229+

230+

231+-- why isn't this in vinyl?

232+recordToList'

233+ :: (V.RecordToList as, V.RMap as)

234+ => (forall x. f x -> a)

235+ -> V.Rec f as

236+ -> [a]

237+recordToList' f = V.recordToList . V.rmap (V.Const . f)

src/Roboservant/Types/Breakdown.hs+30−11

@@ -1,11 +1,13 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE DeriveFunctor #-}

45{-# LANGUAGE DerivingStrategies #-}

56{-# LANGUAGE FlexibleInstances #-}

67{-# LANGUAGE GADTs #-}

78{-# LANGUAGE GeneralizedNewtypeDeriving #-}

89{-# LANGUAGE LambdaCase #-}

10+{-# LANGUAGE MultiParamTypeClasses #-}

911{-# LANGUAGE PolyKinds #-}

1012{-# LANGUAGE ScopedTypeVariables #-}

1113{-# LANGUAGE StandaloneDeriving #-}

@@ -25,16 +27,32 @@ import Data.Map.Strict (Map)

2527import Data.Maybe (fromMaybe)

2628import Data.Proxy (Proxy (..))

2729import Data.Typeable (TypeRep, Typeable, typeRep)

30+import qualified Data.Dependent.Map as DM

31+import Data.Dependent.Map (DMap)

32+import qualified Type.Reflection as R

33+import Data.Dependent.Sum

34+import Data.Kind

2835

2936data Provenance

30− = Provenance TypeRep Int

37+ = Provenance R.SomeTypeRep Int

3138 deriving (Show,Eq)

32−type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))

3339

34−class Typeable x => BuildFrom x where

35− buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))

36− default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))

37− buildFrom = Map.lookup (typeRep (Proxy @x))

40+newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }

41+ deriving (Functor, Show)

42+

43+-- wrap in newtype to give a custom Show instance, since the normal

44+-- instance for DMap is not happy since StashValue needs Show a to show

45+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }

46+ deriving (Semigroup, Monoid)

47+

48+instance Show Stash where

49+ showsPrec i (Stash x) = showsPrec i $

50+ Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x

51+

52+class Typeable x => BuildFrom (x :: Type) where

53+ buildFrom :: Stash -> Maybe (StashValue x)

54+ default buildFrom :: Stash -> Maybe (StashValue x)

55+ buildFrom = DM.lookup R.typeRep . getStash

3856

3957 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

4058

@@ -50,11 +68,12 @@ promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . f

5068instance BuildFrom Bool

5169

5270instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

53− buildFrom dict = Just $ fmap toDyn <$> options

54− where options :: NonEmpty ([Provenance], Maybe x)

55− options = ([],Nothing) :|

56− (maybe [] NEL.toList . fmap (fmap (fmap (Just . promisedDyn @x)))

57− $ buildFrom @x dict)

71+ buildFrom dict = Just options

72+ where options :: StashValue (Maybe x)

73+ options = StashValue $

74+ ([],Nothing) :|

75+ (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict

76+ )

5877

5978class Breakdown x where

6079 breakdown :: x -> NonEmpty Dynamic

src/Roboservant/Types/ReifiedApi.hs+93−56

@@ -2,10 +2,13 @@

22{-# LANGUAGE AllowAmbiguousTypes #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE DerivingStrategies #-}

5+{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

68{-# LANGUAGE GeneralizedNewtypeDeriving #-}

79{-# LANGUAGE LambdaCase #-}

810{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE RecordWildCards #-}

912{-# LANGUAGE ScopedTypeVariables #-}

1013{-# LANGUAGE StandaloneDeriving #-}

1114{-# LANGUAGE TupleSections #-}

@@ -18,43 +21,76 @@ module Roboservant.Types.ReifiedApi where

1821

1922

2023import Control.Monad.Except (runExceptT)

24+import Data.Bifunctor

25+import Data.Dependent.Sum

2126import Data.Dynamic (Dynamic, toDyn)

2227import Data.Function ((&))

28+import Data.Kind

29+import Data.List.NonEmpty (NonEmpty)

2330import Data.Typeable (TypeRep, Typeable, typeRep)

31+import GHC.Generics ((:*:)(..))

2432import GHC.TypeLits (Symbol)

33+import Roboservant.Types.Breakdown

34+import Roboservant.Types.FlattenServer

2535import Servant

2636import Servant.API.Modifiers(FoldRequired,FoldLenient)

27−import Roboservant.Types.FlattenServer

28−import Roboservant.Types.Breakdown

29−import Data.List.NonEmpty (NonEmpty)

37+import qualified Data.Text as T

38+import qualified Data.Vinyl as V

39+import qualified Data.Vinyl.Curry as V

40+import qualified Type.Reflection as R

3041

3142

3243newtype ApiOffset = ApiOffset Int

3344 deriving (Eq, Show)

3445 deriving newtype (Enum, Num)

3546

36−type ReifiedEndpoint = ([(TypeRep, Stash -> Maybe (NonEmpty ([Provenance], Dynamic)))], Dynamic)

47+type TypedF = (:*:) R.TypeRep

48+

49+newtype Argument a = Argument

50+ { getArgument :: Stash -> Maybe (StashValue a)

51+ }

52+

53+data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint

54+ { reArguments :: V.Rec (TypedF Argument) as

55+ , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

56+ }

3757

3858type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]

3959

60+tagType :: Typeable a => f a -> TypedF f a

61+tagType = (R.typeRep :*:)

4062

4163class ToReifiedApi (endpoints :: [*]) where

4264 toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

4365

44−class ToReifiedEndpoint (endpoint :: *) where

45− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint

66+class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint

67+ , V.RecordToList (EndpointArgs endpoint)

68+ , V.RMap (EndpointArgs endpoint)

69+ ) => ToReifiedEndpoint (endpoint :: *) where

70+ type EndpointArgs endpoint :: [Type]

71+ type EndpointRes endpoint :: Type

72+

73+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)

4674

4775instance ToReifiedApi '[] where

4876 toReifiedApi NoEndpoints _ = []

4977

5078instance

51− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>

79+ ( Typeable (EndpointRes endpoint)

80+ , NormalizeFunction (ServerT endpoint Handler)

81+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))

82+ , ToReifiedEndpoint endpoint

83+ , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)

84+ ) =>

5285 ToReifiedApi (endpoint : endpoints)

5386 where

5487 toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

55− (0,) (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))

56− : map

57− (\(n, x) -> (n + 1, x))

88+ (0, ReifiedEndpoint

89+ { reArguments = reifiedEndpointArguments @endpoint

90+ , reEndpointFunc = normalize endpoint

91+ }

92+ )

93+ : (map . first) (+1)

5894 (toReifiedApi endpoints (Proxy @endpoints))

5995

6096class NormalizeFunction m where

@@ -71,35 +107,37 @@ instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where

71107 Left serverError -> pure (Left serverError)

72108 Right x -> pure $ Right $ breakdown x

73109

74−-- pure (Right (typeRep (Proxy @x), toDyn x))

75−

76110instance

77111 (Typeable responseType, Breakdown responseType) =>

78112 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

79113 where

80− toReifiedEndpoint endpoint _ = id

81− ([], endpoint)

114+ type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]

115+ type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

116+ reifiedEndpointArguments = V.RNil

82117

83118instance

84119 (ToReifiedEndpoint endpoint) =>

85120 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

86121 where

87− toReifiedEndpoint endpoint _ =

88− toReifiedEndpoint endpoint (Proxy @endpoint)

122+ type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint

123+ type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

124+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

89125

90126instance

91127 (ToReifiedEndpoint endpoint) =>

92128 ToReifiedEndpoint (Description s :> endpoint)

93129 where

94− toReifiedEndpoint endpoint _ =

95− toReifiedEndpoint endpoint (Proxy @endpoint)

130+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint

131+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint

132+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

96133

97134instance

98135 (ToReifiedEndpoint endpoint) =>

99136 ToReifiedEndpoint (Summary s :> endpoint)

100137 where

101− toReifiedEndpoint endpoint _ =

102− toReifiedEndpoint endpoint (Proxy @endpoint)

138+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint

139+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint

140+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

103141

104142instance

105143 (Typeable requestType

@@ -107,58 +145,57 @@ instance

107145 ,ToReifiedEndpoint endpoint) =>

108146 ToReifiedEndpoint (QueryFlag name :> endpoint)

109147 where

110− toReifiedEndpoint endpoint _ =

111− toReifiedEndpoint endpoint (Proxy @endpoint)

112− & \(args, result) -> ((typeRep (Proxy @Bool),buildFrom @Bool) : args, result)

148+ type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint

149+ type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint

150+ reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint

151+

152+type IfLenient s mods t = If (FoldLenient mods) (Either s t) t

153+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)

154+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)

113155

114156instance

115− ( Typeable (If (FoldRequired mods) paramType (Maybe paramType))

116− , BuildFrom (If (FoldRequired mods) paramType (Maybe paramType))

157+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)

117158 , ToReifiedEndpoint endpoint

118− , SBoolI (FoldRequired mods)) =>

159+ ) =>

119160 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

120161 where

121− toReifiedEndpoint endpoint _ =

122− toReifiedEndpoint endpoint (Proxy @endpoint)

123− & \(args, result) ->

124− ((typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType)))

125− ,buildFrom @(If (FoldRequired mods) paramType (Maybe paramType)))

126− : args, result)

162+ type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint

163+ type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint

164+ reifiedEndpointArguments =

165+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))

166+ V.:& reifiedEndpointArguments @endpoint

167+

127168

128169instance

129− ( Typeable (If (FoldRequired mods) headerType (Maybe headerType))

130− , BuildFrom (If (FoldRequired mods) headerType (Maybe headerType))

170+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)

131171 , ToReifiedEndpoint endpoint

132− , SBoolI (FoldRequired mods)) =>

172+ ) =>

133173 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

134174 where

135− toReifiedEndpoint endpoint _ =

136− toReifiedEndpoint endpoint (Proxy @endpoint)

137− & \(args, result) -> ((typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType)))

138− ,buildFrom @(If (FoldRequired mods) headerType (Maybe headerType)))

139−

140− : args, result)

175+ type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint

176+ type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint

177+ reifiedEndpointArguments =

178+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))

179+ V.:& reifiedEndpointArguments @endpoint

141180

142181instance

143− ( Typeable captureType

144− , BuildFrom captureType

182+ ( BuildFrom (IfLenient String mods captureType)

145183 , ToReifiedEndpoint endpoint) =>

146184 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

147185 where

148− toReifiedEndpoint endpoint _ =

149− toReifiedEndpoint endpoint (Proxy @endpoint)

150− & \(args, result) -> ((typeRep (Proxy @captureType)

151− ,buildFrom @captureType)

152− : args, result)

186+ type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint

187+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

188+ reifiedEndpointArguments =

189+ tagType (Argument (buildFrom @(IfLenient String mods captureType)))

190+ V.:& reifiedEndpointArguments @endpoint

153191

154192instance

155− ( Typeable (If (FoldLenient mods) (Either String requestType) requestType)

156− , BuildFrom (If (FoldLenient mods) (Either String requestType) requestType)

157− , ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>

193+ ( BuildFrom (IfLenient String mods requestType)

194+ , ToReifiedEndpoint endpoint) =>

158195 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

159196 where

160− toReifiedEndpoint endpoint _ =

161− toReifiedEndpoint endpoint (Proxy @endpoint)

162− & \(args, result) -> ((typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType))

163− ,buildFrom @(If (FoldLenient mods) (Either String requestType) requestType))

164− : args, result)

197+ type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint

198+ type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint

199+ reifiedEndpointArguments =

200+ tagType (Argument (buildFrom @(IfLenient String mods requestType)))

201+ V.:& reifiedEndpointArguments @endpoint

stack.yaml+4

@@ -13,6 +13,10 @@ extra-deps:

1313- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736

1414- random-1.2.0

1515- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

16+- vinyl-0.13.0

17+- dependent-sum-0.7.1.0

18+- constraints-extras-0.3.0.2

19+- dependent-map-0.4.0.0

1620- git: https://github.com/hedgehogqa/haskell-hedgehog.git

1721 commit: 03714682586e43b5ddf5c00391035471a6e01238

1822 subdirs:

stack.yaml.lock+28

@@ -67,6 +67,34 @@ packages:

6767 sha256: b9a0c60e2d4786bbb276ce6606027a99615bf703fa3e0f01911e8c6a656c5161

6868 original:

6969 hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

70+- completed:

71+ hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

72+ pantry-tree:

73+ size: 1857

74+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

75+ original:

76+ hackage: vinyl-0.13.0

77+- completed:

78+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

79+ pantry-tree:

80+ size: 290

81+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

82+ original:

83+ hackage: dependent-sum-0.7.1.0

84+- completed:

85+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

86+ pantry-tree:

87+ size: 594

88+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

89+ original:

90+ hackage: constraints-extras-0.3.0.2

91+- completed:

92+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

93+ pantry-tree:

94+ size: 551

95+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

96+ original:

97+ hackage: dependent-map-0.4.0.0

7098- completed:

7199 subdir: hedgehog

72100 name: hedgehog