mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
trying a typerep approach
This commit is contained in:
parent
54a83a6be9
commit
a59a92a042
@ -24,6 +24,8 @@ dependencies:
|
|||||||
|
|
||||||
|
|
||||||
- bytestring
|
- bytestring
|
||||||
|
- hedgehog
|
||||||
|
- containers
|
||||||
- http-client
|
- http-client
|
||||||
- http-media
|
- http-media
|
||||||
- QuickCheck
|
- QuickCheck
|
||||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: e066fe1fb50c5d775ba730812d8afb9db9b9d14e08b2c25ca2277a1d7205d852
|
-- hash: a191221847f306a37d41754b238e8ccc040f3279c30853f21542d4bdf5ab60d3
|
||||||
|
|
||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
@ -29,6 +29,7 @@ library
|
|||||||
exposed-modules:
|
exposed-modules:
|
||||||
Roboservant
|
Roboservant
|
||||||
Roboservant.ContextualGenRequest
|
Roboservant.ContextualGenRequest
|
||||||
|
Roboservant.Hedgehog
|
||||||
Roboservant.StateMachine
|
Roboservant.StateMachine
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_roboservant
|
Paths_roboservant
|
||||||
@ -38,6 +39,8 @@ library
|
|||||||
QuickCheck
|
QuickCheck
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
|
, containers
|
||||||
|
, hedgehog
|
||||||
, hspec
|
, hspec
|
||||||
, http-client
|
, http-client
|
||||||
, http-media
|
, http-media
|
||||||
@ -61,6 +64,8 @@ test-suite roboservant-test
|
|||||||
QuickCheck
|
QuickCheck
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
|
, containers
|
||||||
|
, hedgehog
|
||||||
, hspec
|
, hspec
|
||||||
, http-client
|
, http-client
|
||||||
, http-media
|
, http-media
|
||||||
|
@ -4,12 +4,14 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE KindSignatures #-}
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
{-# LANGUAGE QuantifiedConstraints #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
@ -32,171 +34,189 @@ import Servant
|
|||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
|
import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
|
-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
|
||||||
|
import Data.Dynamic (Dynamic)
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Typeable (TypeRep)
|
||||||
|
import Hedgehog
|
||||||
|
import qualified Hedgehog.Gen as Gen
|
||||||
|
import Roboservant.Hedgehog
|
||||||
|
|
||||||
class HasContextualGenRequest a b where
|
class HasContextualGenRequest a where
|
||||||
genContextualRequest :: Proxy a -> (Int, Gen (BaseUrl -> b -> Request))
|
genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
|
||||||
|
|
||||||
-- -- | Generatable is functionally equivalent to Arbitrary with a default.
|
-- | Generatable is functionally equivalent to Arbitrary with a default.
|
||||||
-- -- It is separate because we want to allow overwriting at will.
|
-- It is separate because we want to allow overwriting at will.
|
||||||
-- class Generatable a where
|
class Generatable a where
|
||||||
-- generator :: Gen [a]
|
generator :: Gen [a]
|
||||||
-- generator = pure []
|
generator = pure []
|
||||||
|
|
||||||
instance ( HasContextualGenRequest a st
|
instance ( HasContextualGenRequest a
|
||||||
, HasContextualGenRequest b st)
|
, HasContextualGenRequest b)
|
||||||
=> HasContextualGenRequest (a :<|> b) st where
|
=> HasContextualGenRequest (a :<|> b) where
|
||||||
genContextualRequest _
|
genContextualRequest _ store
|
||||||
= (lf + rf, frequency [l, r])
|
= case sub of
|
||||||
|
[] -> Nothing
|
||||||
|
_ -> Just (newfreq, Gen.frequency sub)
|
||||||
where
|
where
|
||||||
l@(lf, _) = genContextualRequest (Proxy :: Proxy a)
|
newfreq = sum (map fst sub)
|
||||||
r@(rf, _) = genContextualRequest (Proxy :: Proxy b)
|
sub = catMaybes [l,r]
|
||||||
|
l = genContextualRequest (Proxy :: Proxy a) store
|
||||||
|
r = genContextualRequest (Proxy :: Proxy b) store
|
||||||
|
|
||||||
|
withGeneratable p store cont = cont <$> genContextualRequest p store
|
||||||
|
|
||||||
instance (KnownSymbol path, HasContextualGenRequest b st)
|
instance (KnownSymbol path, HasContextualGenRequest b )
|
||||||
=> HasContextualGenRequest (path :> b) st where
|
=> HasContextualGenRequest (path :> b) where
|
||||||
genContextualRequest _ = (1, do
|
genContextualRequest _ store =
|
||||||
|
withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
|
||||||
|
( oldf, do
|
||||||
|
old <- old'
|
||||||
|
pure $ \burl ->
|
||||||
|
let r = old burl
|
||||||
|
oldPath = path r
|
||||||
|
oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
|
||||||
|
paths = filter (not . BS.null) [new, oldPath']
|
||||||
|
in r { path = "/" <> BS.intercalate "/" paths }
|
||||||
|
|
||||||
old' <- (_old :: _)
|
)
|
||||||
return $ \burl st ->
|
-- , pure ( \burl -> do
|
||||||
let r = old' burl
|
-- _
|
||||||
oldPath = path r
|
-- fmap (Just . (1,)) $ return $ \burl st ->
|
||||||
oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
|
|
||||||
paths = filter (not . BS.null) [new, oldPath']
|
|
||||||
in r { path = "/" <> BS.intercalate "/" paths })
|
|
||||||
where
|
where
|
||||||
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
|
||||||
new = cs $ symbolVal (Proxy :: Proxy path)
|
new = cs $ symbolVal (Proxy :: Proxy path)
|
||||||
|
|
||||||
instance HasContextualGenRequest EmptyAPI st where
|
-- instance HasContextualGenRequest EmptyAPI st where
|
||||||
genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
|
-- genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
|
||||||
|
|
||||||
instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
|
-- instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
|
||||||
|
|
||||||
instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
|
-- instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
|
||||||
|
|
||||||
instance (HasContextualGenRequest b st, ToHttpApiData c )
|
-- instance (HasContextualGenRequest b st, ToHttpApiData c )
|
||||||
=> HasContextualGenRequest (Capture' mods x c :> b) st where
|
-- => HasContextualGenRequest (Capture' mods x c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
old' <- old
|
-- old' <- old
|
||||||
new' <- toUrlPiece <$> _generator
|
-- new' <- toUrlPiece <$> _generator
|
||||||
return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
|
-- return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
|
|
||||||
instance (HasContextualGenRequest b st, ToHttpApiData c )
|
-- instance (HasContextualGenRequest b st, ToHttpApiData c )
|
||||||
=> HasContextualGenRequest (CaptureAll x c :> b) st where
|
-- => HasContextualGenRequest (CaptureAll x c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
old' <- old
|
-- old' <- old
|
||||||
new' <- fmap (cs . toUrlPiece) <$> new
|
-- new' <- fmap (cs . toUrlPiece) <$> new
|
||||||
let new'' = BS.intercalate "/" new'
|
-- let new'' = BS.intercalate "/" new'
|
||||||
return $ \burl st -> let r = old' burl st
|
-- return $ \burl st -> let r = old' burl st
|
||||||
in r { path = new'' <> path r })
|
-- in r { path = new'' <> path r })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
new = _arbitrary :: Gen [c]
|
-- new = _arbitrary :: Gen [c]
|
||||||
|
|
||||||
instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
|
-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
|
||||||
=> HasContextualGenRequest (Header' mods h c :> b) st where
|
-- => HasContextualGenRequest (Header' mods h c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
old' <- old
|
-- old' <- old
|
||||||
new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
|
-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
|
||||||
return $ \burl st -> let r = old' burl st in r {
|
-- return $ \burl st -> let r = old' burl st in r {
|
||||||
requestHeaders = (hdr, cs new') : requestHeaders r })
|
-- requestHeaders = (hdr, cs new') : requestHeaders r })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
hdr = fromString $ symbolVal (Proxy :: Proxy h)
|
-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
|
||||||
new = _arbitrary :: Gen c
|
-- new = _arbitrary :: Gen c
|
||||||
|
|
||||||
instance (AllMimeRender x c, HasContextualGenRequest b st)
|
-- instance (AllMimeRender x c, HasContextualGenRequest b st)
|
||||||
=> HasContextualGenRequest (ReqBody' mods x c :> b) st where
|
-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
old' <- old -- TODO: generate lenient
|
-- old' <- old -- TODO: generate lenient
|
||||||
new' <- new
|
-- new' <- new
|
||||||
(ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
|
-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
|
||||||
return $ \burl st -> let r = old' burl st in r {
|
-- return $ \burl st -> let r = old' burl st in r {
|
||||||
requestBody = RequestBodyLBS bd
|
-- requestBody = RequestBodyLBS bd
|
||||||
, requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
|
-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
|
||||||
})
|
-- })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
new = _arbitrary :: Gen c
|
-- new = _arbitrary :: Gen c
|
||||||
|
|
||||||
instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
|
-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
|
||||||
=> HasContextualGenRequest (QueryParam' mods x c :> b) st where
|
-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
new' <- new -- TODO: generate lenient or/and optional
|
-- new' <- new -- TODO: generate lenient or/and optional
|
||||||
old' <- old
|
-- old' <- old
|
||||||
return $ \burl st -> let
|
-- return $ \burl st -> let
|
||||||
r = old' burl st
|
-- r = old' burl st
|
||||||
newExpr = param <> "=" <> cs (toQueryParam new')
|
-- newExpr = param <> "=" <> cs (toQueryParam new')
|
||||||
qs = queryString r in r {
|
-- qs = queryString r in r {
|
||||||
queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
|
-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
-- param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
new = _arbitrary :: Gen c
|
-- new = _arbitrary :: Gen c
|
||||||
|
|
||||||
instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
|
-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
|
||||||
=> HasContextualGenRequest (QueryParams x c :> b) st where
|
-- => HasContextualGenRequest (QueryParams x c :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
new' <- _fetch
|
-- (new' :: c) <- _fetch
|
||||||
old' <- old
|
-- old' <- old
|
||||||
return $ \burl st -> let r = old' burl st in r {
|
-- return $ \burl st -> let r = old' burl st in r {
|
||||||
queryString = queryString r
|
-- queryString = queryString r
|
||||||
<> if length new' > 0 then fold (toParam <$> new') else ""})
|
-- <> if length new' > 0 then fold (toParam <$> new') else ""})
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
-- param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
toParam c = param <> "[]=" <> cs (toQueryParam c)
|
-- toParam c = param <> "[]=" <> cs (toQueryParam c)
|
||||||
fold = foldr1 (\a b -> a <> "&" <> b)
|
-- fold = foldr1 (\a b -> a <> "&" <> b)
|
||||||
|
|
||||||
instance (KnownSymbol x, HasContextualGenRequest b st)
|
-- instance (KnownSymbol x, HasContextualGenRequest b st)
|
||||||
=> HasContextualGenRequest (QueryFlag x :> b) st where
|
-- => HasContextualGenRequest (QueryFlag x :> b) st where
|
||||||
genContextualRequest _ = (oldf, do
|
-- genContextualRequest _ = (oldf, do
|
||||||
old' <- old
|
-- old' <- old
|
||||||
return $ \burl st -> let r = old' burl st
|
-- return $ \burl st -> let r = old' burl st
|
||||||
qs = queryString r in r {
|
-- qs = queryString r in r {
|
||||||
queryString = if BS.null qs then param else param <> "&" <> qs })
|
-- queryString = if BS.null qs then param else param <> "&" <> qs })
|
||||||
where
|
-- where
|
||||||
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
-- param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
|
|
||||||
instance (ReflectMethod method)
|
-- instance (ReflectMethod method)
|
||||||
=> HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
|
-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
|
||||||
genContextualRequest _ = (1, return $ \burl st -> defaultRequest
|
-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
|
||||||
{ host = cs $ baseUrlHost burl
|
-- { host = cs $ baseUrlHost burl
|
||||||
, port = baseUrlPort burl
|
-- , port = baseUrlPort burl
|
||||||
, secure = baseUrlScheme burl == Https
|
-- , secure = baseUrlScheme burl == Https
|
||||||
, method = reflectMethod (Proxy :: Proxy method)
|
-- , method = reflectMethod (Proxy :: Proxy method)
|
||||||
})
|
-- })
|
||||||
|
|
||||||
instance (ReflectMethod method)
|
-- instance (ReflectMethod method)
|
||||||
=> HasContextualGenRequest (NoContentVerb (method :: k)) st where
|
-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
|
||||||
genContextualRequest _ = (1, return $ \burl st -> defaultRequest
|
-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
|
||||||
{ host = cs $ baseUrlHost burl
|
-- { host = cs $ baseUrlHost burl
|
||||||
, port = baseUrlPort burl
|
-- , port = baseUrlPort burl
|
||||||
, secure = baseUrlScheme burl == Https
|
-- , secure = baseUrlScheme burl == Https
|
||||||
, method = reflectMethod (Proxy :: Proxy method)
|
-- , method = reflectMethod (Proxy :: Proxy method)
|
||||||
})
|
-- })
|
||||||
|
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
-- TODO: Try logging in
|
-- -- TODO: Try logging in
|
||||||
instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
|
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
|
||||||
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
|
||||||
|
41
src/Roboservant/Hedgehog.hs
Normal file
41
src/Roboservant/Hedgehog.hs
Normal file
@ -0,0 +1,41 @@
|
|||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
module Roboservant.Hedgehog where
|
||||||
|
|
||||||
|
import Hedgehog
|
||||||
|
import Hedgehog.Gen
|
||||||
|
import qualified Hedgehog.Range as Range
|
||||||
|
|
||||||
|
-- | Uses a weighted distribution to randomly select one of the generators in
|
||||||
|
-- the list.
|
||||||
|
--
|
||||||
|
-- This generator shrinks towards the first generator in the list.
|
||||||
|
--
|
||||||
|
-- This is to be used when the generator returning a Nothing indicates
|
||||||
|
-- that it will never succeed so should be abandoned entirely.
|
||||||
|
--
|
||||||
|
-- /The input list must be non-empty./
|
||||||
|
--
|
||||||
|
frequencyM :: MonadGen m => [(Int, m (Maybe a))] -> m (Maybe a)
|
||||||
|
frequencyM = \case
|
||||||
|
[] -> pure Nothing
|
||||||
|
-- error "Hedgehog.Gen.frequency: used with empty list"
|
||||||
|
xs0 -> do
|
||||||
|
let
|
||||||
|
pick acc n = \case
|
||||||
|
[] -> pure Nothing
|
||||||
|
-- error "Hedgehog.Gen.frequency/pick: used with empty list"
|
||||||
|
(k, x) : xs ->
|
||||||
|
if n <= k then
|
||||||
|
x >>= \case
|
||||||
|
Nothing -> do
|
||||||
|
-- this one will never come out right, so reassemble list without it
|
||||||
|
frequencyM (acc <> xs)
|
||||||
|
Just y -> pure $ Just y
|
||||||
|
else
|
||||||
|
pick ((k,x):acc) (n - k) xs
|
||||||
|
|
||||||
|
total =
|
||||||
|
sum (fmap fst xs0)
|
||||||
|
|
||||||
|
n <- integral $ Range.constant 1 total
|
||||||
|
pick [] n xs0
|
@ -2,15 +2,15 @@
|
|||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
module Roboservant.StateMachine where
|
module Roboservant.StateMachine where
|
||||||
|
|
||||||
import Servant.Server (Server)
|
import Roboservant.ContextualGenRequest
|
||||||
import Test.QuickCheck (Property)
|
import Servant.Server (Server)
|
||||||
|
import Test.QuickCheck (Property)
|
||||||
import Test.StateMachine
|
import Test.StateMachine
|
||||||
import Roboservant.ContextualGenRequest
|
|
||||||
|
|
||||||
|
|
||||||
-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
|
-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
|
||||||
-- this into a property
|
-- this into a property
|
||||||
--
|
--
|
||||||
-- TODO: how do we tie the model, command and response types to the Server?
|
-- TODO: how do we tie the model, command and response types to the Server?
|
||||||
genStateMachine :: HasContextualGenRequest a b => Server a -> StateMachine model command IO response
|
genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine model command IO response
|
||||||
genStateMachine = undefined
|
genStateMachine = undefined
|
||||||
|
Loading…
Reference in New Issue
Block a user