@@ -18,75 +18,94 @@
1818
1919module Roboservant.StateMachine
2020 ( prop_sequential,
21− prop_concurrent,
2221 )
2322where
2423
24+-- prop_concurrent,
25+
2526import Control.Monad (guard)
2627import Control.Monad.IO.Class (MonadIO, liftIO)
2728import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
28−import Data.IORef (IORef, newIORef)
2929import qualified Data.List.NonEmpty as NEL
3030import qualified Data.Map.Strict as Map
3131import Data.Maybe (mapMaybe)
3232import Data.Typeable (TypeRep)
33−import Debug.Trace
34−import GHC.IORef (readIORef)
3533import Hedgehog
34+ ( Callback (Update),
35+ Command (Command),
36+ Concrete,
37+ MonadGen,
38+ Opaque (Opaque),
39+ PropertyT,
40+ Symbolic,
41+ Var,
42+ executeSequential,
43+ forAll,
44+ opaque,
45+ )
3646import qualified Hedgehog.Gen as Gen
3747import qualified Hedgehog.Range as Range
38−import Roboservant.Hedgehog
48+import Roboservant.Hedgehog (elementOrFail)
3949import Roboservant.Types
40−import Servant
50+ ( ApiOffset (..),
51+ FlattenServer (..),
52+ Op (..),
53+ ReifiedApi,
54+ State (..),
55+ ToReifiedApi (..),
56+ emptyState,
57+ )
58+import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
4159import Type.Reflection (SomeTypeRep)
4260
4361callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
4462callEndpoint staticRoutes =
4563 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
4664 gen State {..} = case chewable of
47− -- Chewable values still need to be broken down.
48− (c : _) -> Just $ pure $ Chewable c
65+ (_ : _) -> Just $ do
66+ (offset, v) <- Gen.element (zip [0 ..] chewable)
67+ pure $ Chewable offset _ _
4968 _ -> do
5069 guard $ not $ null options
5170 pure $ uncurry Op <$> chooseOne options
5271 where
5372 chooseOne ::
5473 MonadGen n =>
55− [ ( ApiOffset,
56− [[Var (Opaque (IORef Dynamic)) Symbolic]]
74+ [ ( a,
75+ [[b]]
5776 )
5877 ] ->
5978 n
60− ( ApiOffset,
61− [Var (Opaque (IORef Dynamic)) Symbolic]
79+ ( a,
80+ [b]
6281 )
6382 chooseOne opts = do
6483 (offset, args) <- elementOrFail opts
6584 (offset,) <$> mapM elementOrFail args
66− options :: [(ApiOffset, [[Var (Opaque (IORef Dynamic)) Symbolic]])]
85+ options :: [(ApiOffset, [[Var (Opaque Dynamic) Symbolic]])]
6786 options =
6887 mapMaybe
69− ( \(offset, (argreps, _retType, _dynCall)) -> (offset,) <$> do
88+ ( \(offset, (argreps, _dynCall)) -> (offset,) <$> do
7089 mapM fillableWith argreps
7190 )
7291 staticRoutes
73− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
92+ fillableWith :: TypeRep -> Maybe [Var (Opaque Dynamic) Symbolic]
7493 fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
7594 execute ::
7695 (MonadIO m) =>
7796 Op Concrete ->
78− m (Opaque (IORef Dynamic))
97+ m (Opaque (NEL.NonEmpty Dynamic))
7998 -- bit subtle here - a chewable v _also_ gets a var, because chewing it should
8099 -- only give subcomponents.
81− execute (Chewable v) = Opaque <$> liftIO (newIORef v)
100+ execute (Chewable offset trs v) = _ -- pure . Opaque $ opaque $ pure v -- pure $ Opaque v -- <$> liftIO (newIORef v)
82101 execute (Op (ApiOffset offset) args) = do
83102 fmap Opaque . liftIO $ do
84− realArgs <- mapM (readIORef . opaque) args
85− let (_offset, (_staticArgs, _ret, endpoint)) = staticRoutes !! offset
103+ let realArgs = map opaque args
104+ let (_offset, (_staticArgs, endpoint)) = staticRoutes !! offset
86105 -- now, magic happens: we apply some dynamic arguments to a dynamic
87106 -- function and hopefully something useful pops out the end.
88107 func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
89− let showable = map dynTypeRep (endpoint : realArgs)
108+ let showable = "blah" -- map dynTypeRep (_endpoint : realArgs)
90109 case func of
91110 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
92111 Just (f') -> do
@@ -94,35 +113,43 @@ callEndpoint staticRoutes =
94113 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
95114 Just f -> liftIO f >>= \case
96115 Left (serverError :: ServerError) -> error (show serverError)
97− Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
116+ Right (_typeRep :: SomeTypeRep, (dyn :: NEL.NonEmpty Dynamic)) -> pure dyn
98117 in Command
99118 gen
100119 execute
101− [ Update $ \s@State {..} op o' ->
102− case op of
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− }
110− (Op (ApiOffset offset) _args) ->
111− s
112− { stateRefs =
113− let (_, (_, tr, _)) = staticRoutes !! offset
114− in Map.insertWith
115− (<>)
116− tr
117− (pure o')
118− stateRefs
119− }
120+ [ update
120121 ]
121122
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 []
123+update :: Callback Op (Opaque (NEL.NonEmpty Dynamic)) State
124+update = Update $ \s@State {..} op o' ->
125+ case op of
126+ Chewable offset tr v -> case _extract offset trs chewable of
127+ Nothing -> error "internal error"
128+ Just (tr, _extracted, rest) ->
129+ s
130+ { stateRefs =
131+ -- so, what's going on here... we need to be able to grab and merge
132+ -- a list of (typeref, var). this means that we need to be able to pull
133+ -- out typereps symbolically too, we can't just rely on the dynamic being there.
134+ -- Map.insertWith (<>) (dynTypeRep v) _ (pure o') stateRefs,
135+ Map.insertWith (<>) tr (_ o') stateRefs,
136+ chewable = rest
137+ }
138+ (Op (ApiOffset _offset) _args) ->
139+ s
140+ { chewable = _ o' : chewable
141+ -- Map.insertWith
142+ -- (<>)
143+ -- tr
144+ -- (pure o')
145+ -- stateRefs
146+ }
147+
148+extract :: Int -> [a] -> Maybe (a, [a])
149+extract = undefined
150+
151+preload :: (MonadGen n, MonadIO m) => Dynamic -> Command n m State
152+preload = undefined
126153
127154prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
128155prop_sequential server seed = do
@@ -131,20 +158,19 @@ prop_sequential server seed = do
131158 forAll $ do
132159 Gen.sequential
133160 (Range.linear 1 100)
134− (emptyState {chewable = seed})
135− [callEndpoint reifiedApi]
136− executeSequential (emptyState {chewable = seed}) actions
137−
138−prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
139−prop_concurrent server seed =
140− let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
141− in do
142− actions <-
143− forAll $
144− Gen.parallel
145− (Range.linear 1 50)
146− (Range.linear 1 10)
147− (emptyState {chewable = seed})
148− [callEndpoint reifiedApi]
149− test $
150− executeParallel (emptyState {chewable = seed}) actions
161+ emptyState
162+ (fmap preload seed <> [callEndpoint reifiedApi])
163+ executeSequential emptyState actions
164+-- prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()
165+-- prop_concurrent server seed =
166+-- let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
167+-- in do
168+-- actions <-
169+-- forAll $
170+-- Gen.parallel
171+-- (Range.linear 1 50)
172+-- (Range.linear 1 10)
173+-- (emptyState {chewable = seed})
174+-- [callEndpoint reifiedApi]
175+-- test $
176+-- executeParallel (emptyState {chewable = seed}) actions