0be3abc · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

working through details of chewable dynamics

0be3abcMark Wotton6 years ago

src/Roboservant/StateMachine.hs+26−18

compare with master

unifiedsplit

@@ -22,6 +22,7 @@ module Roboservant.StateMachine

22 )

23where

25+import Control.Monad (guard)

25import Control.Monad.IO.Class (MonadIO, liftIO)

26import Control.Monad.IO.Class (MonadIO, liftIO)

26import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)

27import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)

27import Data.IORef (IORef, newIORef)

28import Data.IORef (IORef, newIORef)

@@ -42,13 +43,12 @@ import Type.Reflection (SomeTypeRep)

42callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State

43callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State

43callEndpoint staticRoutes =

44callEndpoint staticRoutes =

44 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))

45 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))

45− gen State {..} = case preloads of

46+ gen State {..} = case chewable of

46− (v : _) -> Just $ pure $ Preload (dynTypeRep v) v

47+ -- Chewable values still need to be broken down.

48+ (c : _) -> Just $ pure $ Chewable c

47− _ ->

49+ _ -> do

48− if any null options

50+ guard $ not $ null options

49− then Nothing

50− else Just $ do

51− uncurry Op <$> chooseOne options

51+ pure $ uncurry Op <$> chooseOne options

52 where

53 chooseOne ::

54 MonadGen n =>

@@ -76,7 +76,9 @@ callEndpoint staticRoutes =

76 (MonadIO m) =>

77 Op Concrete ->

78 m (Opaque (IORef Dynamic))

79+ -- bit subtle here - a chewable v _also_ gets a var, because chewing it should

80+ -- only give subcomponents.

79− execute (Preload _tr v) = Opaque <$> liftIO (newIORef v)

81+ execute (Chewable v) = Opaque <$> liftIO (newIORef v)

80 execute (Op (ApiOffset offset) args) = do

82 execute (Op (ApiOffset offset) args) = do

81 fmap Opaque . liftIO $ do

83 fmap Opaque . liftIO $ do

82 realArgs <- mapM (readIORef . opaque) args

84 realArgs <- mapM (readIORef . opaque) args

@@ -98,12 +100,13 @@ callEndpoint staticRoutes =

98 execute

100 execute

99 [ Update $ \s@State {..} op o' ->

101 [ Update $ \s@State {..} op o' ->

100 case op of

102 case op of

101− Preload tr _v ->

103+ Chewable v ->

104+ let (c : cs) = chewable

102− s

105+ in s

103− { stateRefs =

106+ { stateRefs =

104− Map.insertWith (<>) tr (pure o') stateRefs,

107+ Map.insertWith (<>) (dynTypeRep v) (pure o') stateRefs,

105− preloads = drop 1 preloads

108+ chewable = (breakdownDynamic c) <> cs

106− }

109+ }

107 (Op (ApiOffset offset) _args) ->

110 (Op (ApiOffset offset) _args) ->

108 s

111 s

109 { stateRefs =

112 { stateRefs =

@@ -116,6 +119,11 @@ callEndpoint staticRoutes =

116 }

119 }

117 ]

120 ]

118

121

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+

119prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

127prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

120prop_sequential server seed = do

128prop_sequential server seed = do

121 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

129 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

@@ -123,9 +131,9 @@ prop_sequential server seed = do

123 forAll $ do

131 forAll $ do

124 Gen.sequential

132 Gen.sequential

125 (Range.linear 1 100)

133 (Range.linear 1 100)

126− (State mempty seed)

134+ (emptyState {chewable = seed})

127 [callEndpoint reifiedApi]

135 [callEndpoint reifiedApi]

128− executeSequential (State mempty seed) actions

136+ executeSequential (emptyState {chewable = seed}) actions

129

137

130prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

138prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

131prop_concurrent server seed =

139prop_concurrent server seed =

@@ -136,7 +144,7 @@ prop_concurrent server seed =

136 Gen.parallel

144 Gen.parallel

137 (Range.linear 1 50)

145 (Range.linear 1 50)

138 (Range.linear 1 10)

146 (Range.linear 1 10)

139− (State mempty seed)

147+ (emptyState {chewable = seed})

140 [callEndpoint reifiedApi]

148 [callEndpoint reifiedApi]

141 test $

149 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)

31import Roboservant.Types.FlattenServer

32import Roboservant.Types.ReifiedApi

34+-- | preloads are basically done, just waiting for a Var.

35+-- chewable things may have more structure in them.

34data State v

36data State v

35 = State

37 = State

36 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v)),

38 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v)),

37− preloads :: [Dynamic]

39+ chewable :: [Dynamic]

38 }

40 }

42+emptyState :: forall v. State v

43+emptyState = State mempty mempty

44+

40-- | we need to specify an offset because it's entirely possible to have two

45-- | we need to specify an offset because it's entirely possible to have two

41-- functions with the same arguments that do different things.

46-- functions with the same arguments that do different things.

42data Op (v :: * -> *)

47data Op (v :: * -> *)

@@ -44,11 +49,11 @@ data Op (v :: * -> *)

44 -- because a single argument to the api could be a sum type with many constructors and varying

49 -- because a single argument to the api could be a sum type with many constructors and varying

45 -- arguments itself.

50 -- arguments itself.

46 Op ApiOffset [(Var (Opaque (IORef Dynamic)) v)]

51 Op ApiOffset [(Var (Opaque (IORef Dynamic)) v)]

47− | Preload TypeRep Dynamic

52+ | Chewable Dynamic

49deriving instance Show (Op Symbolic)

54deriving instance Show (Op Symbolic)

51instance HTraversable Op where

56instance HTraversable Op where

52 htraverse r = \case

57 htraverse r = \case

53 Op offset args -> Op offset <$> traverse (htraverse r) args

58 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

32 hedgehog $ RS.prop_sequential @Foo.Api Foo.server []

34 describe "Headers" $ do

35+ modifyMaxSuccess (const 10000) $

36+

35− shouldFail $ it "should find a failure that's dependent on using header info" $ do

37+ shouldFail $ it "should find a failure that's dependent on using header info" $ do

36− let _ = hedgehog $ RS.prop_sequential @Headers.Api Headers.server []

38+ hedgehog $ RS.prop_sequential @Headers.Api Headers.server []

37− pending

39+ -- pending

39 -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

41 -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

40 -- -- could: it's mostly here to show how to test for concurrency problems.

42 -- -- could: it's mostly here to show how to test for concurrency problems.