git.iko.soy/roboservant
on master help sign in
working through details of chewable dynamics
commit0be3abceb234df2fe35240b044cd4e8290ef6841 authorMark Wotton <mwotton@gmail.com> dateSat 26 Sep 2020, 17:49 (6 years ago) parent9d70ccc
3 files changed+39−24
compare with master
unifiedsplit
src/Roboservant/StateMachine.hs+26−18 src/Roboservant/Types.hs+8−3 test/Spec.hs+5−3
src/Roboservant/StateMachine.hs+26−18
@@ -22,6 +22,7 @@ module Roboservant.StateMachine
2222 )
2323where
2424
25+import Control.Monad (guard)
2526import Control.Monad.IO.Class (MonadIO, liftIO)
2627import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
2728import Data.IORef (IORef, newIORef)
@@ -42,13 +43,12 @@ import Type.Reflection (SomeTypeRep)
4243callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
4344callEndpoint staticRoutes =
4445 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
45− gen State {..} = case preloads of
46− (v : _) -> Just $ pure $ Preload (dynTypeRep v) v
47− _ ->
48− if any null options
49− then Nothing
50− else Just $ do
51− uncurry Op <$> chooseOne options
46+ gen State {..} = case chewable of
47+ -- Chewable values still need to be broken down.
48+ (c : _) -> Just $ pure $ Chewable c
49+ _ -> do
50+ guard $ not $ null options
51+ pure $ uncurry Op <$> chooseOne options
5252 where
5353 chooseOne ::
5454 MonadGen n =>
@@ -76,7 +76,9 @@ callEndpoint staticRoutes =
7676 (MonadIO m) =>
7777 Op Concrete ->
7878 m (Opaque (IORef Dynamic))
79− execute (Preload _tr v) = Opaque <$> liftIO (newIORef v)
79+ -- bit subtle here - a chewable v _also_ gets a var, because chewing it should
80+ -- only give subcomponents.
81+ execute (Chewable v) = Opaque <$> liftIO (newIORef v)
8082 execute (Op (ApiOffset offset) args) = do
8183 fmap Opaque . liftIO $ do
8284 realArgs <- mapM (readIORef . opaque) args
@@ -98,12 +100,13 @@ callEndpoint staticRoutes =
98100 execute
99101 [ Update $ \s@State {..} op o' ->
100102 case op of
101− Preload tr _v ->
102− s
103− { stateRefs =
104− Map.insertWith (<>) tr (pure o') stateRefs,
105− preloads = drop 1 preloads
106− }
103+ Chewable v ->
104+ let (c : cs) = chewable
105+ in s
106+ { stateRefs =
107+ Map.insertWith (<>) (dynTypeRep v) (pure o') stateRefs,
108+ chewable = (breakdownDynamic c) <> cs
109+ }
107110 (Op (ApiOffset offset) _args) ->
108111 s
109112 { stateRefs =
@@ -116,6 +119,11 @@ callEndpoint staticRoutes =
116119 }
117120 ]
118121
122+-- | just a stub for now - this is where we probably have to start using ConstrainedDynamic
123+-- so we can pack them in with a Breakdown constraint. TODO.
124+breakdownDynamic :: Dynamic -> [Dynamic]
125+breakdownDynamic = const []
126+
119127prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
120128prop_sequential server seed = do
121129 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
@@ -123,9 +131,9 @@ prop_sequential server seed = do
123131 forAll $ do
124132 Gen.sequential
125133 (Range.linear 1 100)
126− (State mempty seed)
134+ (emptyState {chewable = seed})
127135 [callEndpoint reifiedApi]
128− executeSequential (State mempty seed) actions
136+ executeSequential (emptyState {chewable = seed}) actions
129137
130138prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
131139prop_concurrent server seed =
@@ -136,7 +144,7 @@ prop_concurrent server seed =
136144 Gen.parallel
137145 (Range.linear 1 50)
138146 (Range.linear 1 10)
139− (State mempty seed)
147+ (emptyState {chewable = seed})
140148 [callEndpoint reifiedApi]
141149 test $
142− executeParallel (State mempty seed) actions
150+ executeParallel (emptyState {chewable = seed}) actions
src/Roboservant/Types.hs+8−3
@@ -31,12 +31,17 @@ import Hedgehog (HTraversable (..), Opaque, Symbolic, Var)
3131import Roboservant.Types.FlattenServer
3232import Roboservant.Types.ReifiedApi
3333
34+-- | preloads are basically done, just waiting for a Var.
35+-- chewable things may have more structure in them.
3436data State v
3537 = State
3638 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v)),
37− preloads :: [Dynamic]
39+ chewable :: [Dynamic]
3840 }
3941
42+emptyState :: forall v. State v
43+emptyState = State mempty mempty
44+
4045-- | we need to specify an offset because it's entirely possible to have two
4146-- functions with the same arguments that do different things.
4247data Op (v :: * -> *)
@@ -44,11 +49,11 @@ data Op (v :: * -> *)
4449 -- because a single argument to the api could be a sum type with many constructors and varying
4550 -- arguments itself.
4651 Op ApiOffset [(Var (Opaque (IORef Dynamic)) v)]
47− | Preload TypeRep Dynamic
52+ | Chewable Dynamic
4853
4954deriving instance Show (Op Symbolic)
5055
5156instance HTraversable Op where
5257 htraverse r = \case
5358 Op offset args -> Op offset <$> traverse (htraverse r) args
54− Preload tr v -> pure $ Preload tr v
59+ Chewable v -> pure $ Chewable v
test/Spec.hs+5−3
@@ -32,9 +32,11 @@ spec = do
3232 hedgehog $ RS.prop_sequential @Foo.Api Foo.server []
3333
3434 describe "Headers" $ do
35− shouldFail $ it "should find a failure that's dependent on using header info" $ do
36− let _ = hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
37− pending
35+ modifyMaxSuccess (const 10000) $
36+
37+ shouldFail $ it "should find a failure that's dependent on using header info" $ do
38+ hedgehog $ RS.prop_sequential @Headers.Api Headers.server []
39+ -- pending
3840
3941 -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
4042 -- -- could: it's mostly here to show how to test for concurrency problems.