trying a typerep approach

package.yaml

@@ -24,6 +24,8 @@ dependencies:
 
 
 - bytestring
+- hedgehog
+- containers
 - http-client
 - http-media
 - QuickCheck

roboservant.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e066fe1fb50c5d775ba730812d8afb9db9b9d14e08b2c25ca2277a1d7205d852
+-- hash: a191221847f306a37d41754b238e8ccc040f3279c30853f21542d4bdf5ab60d3
 
 name:           roboservant
 version:        0.1.0.0
@@ -29,6 +29,7 @@ library
   exposed-modules:
       Roboservant
       Roboservant.ContextualGenRequest
+      Roboservant.Hedgehog
       Roboservant.StateMachine
   other-modules:
       Paths_roboservant
@@ -38,6 +39,8 @@ library
       QuickCheck
     , base >=4.7 && <5
     , bytestring
+    , containers
+    , hedgehog
     , hspec
     , http-client
     , http-media
@@ -61,6 +64,8 @@ test-suite roboservant-test
       QuickCheck
     , base >=4.7 && <5
     , bytestring
+    , containers
+    , hedgehog
     , hspec
     , http-client
     , http-media

src/Roboservant/ContextualGenRequest.hs

@@ -4,12 +4,14 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
@@ -32,171 +34,189 @@ import           Servant
 import           Servant.API
 import           Servant.API.ContentTypes (AllMimeRender, allMimeRender)
 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
-  genContextualRequest :: Proxy a -> (Int, Gen (BaseUrl -> b -> Request))
+class HasContextualGenRequest a where
+  genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
 
--- -- | Generatable is functionally equivalent to Arbitrary with a default.
--- --   It is separate because we want to allow overwriting at will.
--- class Generatable a where
---   generator :: Gen [a]
---   generator = pure []
+-- | Generatable is functionally equivalent to Arbitrary with a default.
+--   It is separate because we want to allow overwriting at will.
+class Generatable a where
+  generator :: Gen [a]
+  generator = pure []
 
-instance ( HasContextualGenRequest a st
-         , HasContextualGenRequest b st)
-  => HasContextualGenRequest (a :<|> b) st where
-    genContextualRequest _
-      = (lf + rf, frequency [l, r])
+instance ( HasContextualGenRequest a
+         , HasContextualGenRequest b)
+  => HasContextualGenRequest  (a :<|> b) where
+    genContextualRequest _ store
+      = case sub of
+          [] -> Nothing
+          _  -> Just (newfreq, Gen.frequency sub)
       where
-        l@(lf, _) = genContextualRequest (Proxy :: Proxy a)
-        r@(rf, _) = genContextualRequest (Proxy :: Proxy b)
+        newfreq = sum (map fst sub)
+        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)
-  => HasContextualGenRequest (path :> b) st where
-    genContextualRequest _ = (1, do
+instance (KnownSymbol path, HasContextualGenRequest b )
+  => HasContextualGenRequest (path :> b) where
+    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 ->
-        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 })
+          )
+--        , pure ( \burl -> do
+--            _
+        -- fmap (Just . (1,)) $ return $ \burl st ->
       where
-        -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+        -- (oldf, old) = genContextualRequest  (Proxy :: Proxy b) store
         new = cs $ symbolVal (Proxy :: Proxy path)
 
-instance HasContextualGenRequest EmptyAPI st where
-  genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
+-- instance HasContextualGenRequest EmptyAPI st where
+--   genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
 
-instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
-  genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
+-- instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
+--   genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
 
-instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
-  genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
+-- instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
+--   genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
 
-instance (HasContextualGenRequest b st, ToHttpApiData c )
-    => HasContextualGenRequest (Capture' mods x c :> b) st where
-    genContextualRequest _ = (oldf, do
-      old' <- old
-      new' <- toUrlPiece <$> _generator
-      return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+-- instance (HasContextualGenRequest b st, ToHttpApiData c )
+--     => HasContextualGenRequest (Capture' mods x c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       old' <- old
+--       new' <- toUrlPiece <$> _generator
+--       return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
 
-instance (HasContextualGenRequest b st, ToHttpApiData c )
-    => HasContextualGenRequest (CaptureAll x c :> b) st where
-    genContextualRequest _ = (oldf, do
-      old' <- old
-      new' <- fmap (cs . toUrlPiece) <$> new
-      let new'' = BS.intercalate "/" new'
-      return $ \burl st -> let r = old' burl st
-        in r { path = new'' <> path r })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        new = _arbitrary  :: Gen [c]
+-- instance (HasContextualGenRequest b st, ToHttpApiData c )
+--     => HasContextualGenRequest (CaptureAll x c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       old' <- old
+--       new' <- fmap (cs . toUrlPiece) <$> new
+--       let new'' = BS.intercalate "/" new'
+--       return $ \burl st -> let r = old' burl st
+--         in r { path = new'' <> path r })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         new = _arbitrary  :: Gen [c]
 
-instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
-    => HasContextualGenRequest (Header' mods h c :> b) st where
-    genContextualRequest _ = (oldf, do
-      old' <- old
-      new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional
-      return $ \burl st -> let r = old' burl st in r {
-          requestHeaders = (hdr, cs new') : requestHeaders r })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        hdr = fromString $ symbolVal (Proxy :: Proxy h)
-        new = _arbitrary :: Gen c
+-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
+--     => HasContextualGenRequest (Header' mods h c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       old' <- old
+--       new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional
+--       return $ \burl st -> let r = old' burl st in r {
+--           requestHeaders = (hdr, cs new') : requestHeaders r })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         hdr = fromString $ symbolVal (Proxy :: Proxy h)
+--         new = _arbitrary :: Gen c
 
-instance (AllMimeRender x c, HasContextualGenRequest b st)
-    => HasContextualGenRequest (ReqBody' mods x c :> b) st where
-    genContextualRequest _ = (oldf, do
-      old' <- old  -- TODO: generate lenient
-      new' <- new
-      (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
-      return $ \burl st -> let r = old' burl st in r {
-          requestBody = RequestBodyLBS bd
-        , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
-        })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        new = _arbitrary :: Gen c
+-- instance (AllMimeRender x c, HasContextualGenRequest b st)
+--     => HasContextualGenRequest (ReqBody' mods x c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       old' <- old  -- TODO: generate lenient
+--       new' <- new
+--       (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
+--       return $ \burl st -> let r = old' burl st in r {
+--           requestBody = RequestBodyLBS bd
+--         , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
+--         })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         new = _arbitrary :: Gen c
 
-instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
-    => HasContextualGenRequest (QueryParam' mods x c :> b) st where
-    genContextualRequest _ = (oldf, do
-      new' <- new  -- TODO: generate lenient or/and optional
-      old' <- old
-      return $ \burl st -> let
-        r = old' burl st
-        newExpr = param <> "=" <> cs (toQueryParam new')
-        qs = queryString r in r {
-          queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        param = cs $ symbolVal (Proxy :: Proxy x)
-        new = _arbitrary :: Gen c
+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
+--     => HasContextualGenRequest (QueryParam' mods x c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       new' <- new  -- TODO: generate lenient or/and optional
+--       old' <- old
+--       return $ \burl st -> let
+--         r = old' burl st
+--         newExpr = param <> "=" <> cs (toQueryParam new')
+--         qs = queryString r in r {
+--           queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         param = cs $ symbolVal (Proxy :: Proxy x)
+--         new = _arbitrary :: Gen c
 
-instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
-    => HasContextualGenRequest (QueryParams x c :> b) st where
-    genContextualRequest _ = (oldf, do
-      new' <- _fetch
-      old' <- old
-      return $ \burl st -> let r = old' burl st in r {
-          queryString = queryString r
-                     <> if length new' > 0 then fold (toParam <$> new') else ""})
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        param = cs $ symbolVal (Proxy :: Proxy x)
-        toParam c = param <> "[]=" <> cs (toQueryParam c)
-        fold = foldr1 (\a b -> a <> "&" <> b)
+-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
+--     => HasContextualGenRequest (QueryParams x c :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       (new' :: c) <- _fetch
+--       old' <- old
+--       return $ \burl st -> let r = old' burl st in r {
+--           queryString = queryString r
+--                      <> if length new' > 0 then fold (toParam <$> new') else ""})
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         param = cs $ symbolVal (Proxy :: Proxy x)
+--         toParam c = param <> "[]=" <> cs (toQueryParam c)
+--         fold = foldr1 (\a b -> a <> "&" <> b)
 
-instance (KnownSymbol x, HasContextualGenRequest b st)
-    => HasContextualGenRequest (QueryFlag x :> b) st where
-    genContextualRequest _ = (oldf, do
-      old' <- old
-      return $ \burl st -> let r = old' burl st
-                               qs = queryString r in r {
-          queryString = if BS.null qs then param else param <> "&" <> qs })
-      where
-        (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-        param = cs $ symbolVal (Proxy :: Proxy x)
+-- instance (KnownSymbol x, HasContextualGenRequest b st)
+--     => HasContextualGenRequest (QueryFlag x :> b) st where
+--     genContextualRequest _ = (oldf, do
+--       old' <- old
+--       return $ \burl st -> let r = old' burl st
+--                                qs = queryString r in r {
+--           queryString = if BS.null qs then param else param <> "&" <> qs })
+--       where
+--         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
+--         param = cs $ symbolVal (Proxy :: Proxy x)
 
-instance (ReflectMethod method)
-    => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
-    genContextualRequest _ = (1, return $ \burl st -> defaultRequest
-       { host = cs $ baseUrlHost burl
-       , port = baseUrlPort burl
-       , secure = baseUrlScheme burl == Https
-       , method = reflectMethod (Proxy :: Proxy method)
-       })
+-- instance (ReflectMethod method)
+--     => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
+--     genContextualRequest _ = (1, return $ \burl st -> defaultRequest
+--        { host = cs $ baseUrlHost burl
+--        , port = baseUrlPort burl
+--        , secure = baseUrlScheme burl == Https
+--        , method = reflectMethod (Proxy :: Proxy method)
+--        })
 
-instance (ReflectMethod method)
-    => HasContextualGenRequest (NoContentVerb (method :: k)) st where
-    genContextualRequest _ = (1, return $ \burl st -> defaultRequest
-       { host = cs $ baseUrlHost burl
-       , port = baseUrlPort burl
-       , secure = baseUrlScheme burl == Https
-       , method = reflectMethod (Proxy :: Proxy method)
-       })
+-- instance (ReflectMethod method)
+--     => HasContextualGenRequest (NoContentVerb (method :: k)) st where
+--     genContextualRequest _ = (1, return $ \burl st -> defaultRequest
+--        { host = cs $ baseUrlHost burl
+--        , port = baseUrlPort burl
+--        , secure = baseUrlScheme burl == Https
+--        , method = reflectMethod (Proxy :: Proxy method)
+--        })
 
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
 
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
 
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
 
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
 
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
 
--- TODO: Try logging in
-instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
-    genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
+-- -- TODO: Try logging in
+-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
+--     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)

src/Roboservant/Hedgehog.hs

@@ -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

src/Roboservant/StateMachine.hs

@@ -2,15 +2,15 @@
 {-# LANGUAGE RankNTypes          #-}
 module Roboservant.StateMachine where
 
-import           Servant.Server    (Server)
-import           Test.QuickCheck   (Property)
+import           Roboservant.ContextualGenRequest
+import           Servant.Server                   (Server)
+import           Test.QuickCheck                  (Property)
 import           Test.StateMachine
-import Roboservant.ContextualGenRequest
 
 
 -- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
 --   this into a property
 --
 -- 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