{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Roboservant.Direct
  ( fuzz',
    Config (..),
    -- TODO come up with something smarter than exporting all this, we should
    -- have some nice error-display functions
    RoboservantException (..),
    FuzzState (..),
    FuzzOp (..),
    FailureType (..),
    Report (..),
  )
where

import Control.Exception.Lifted
  ( Exception,
    Handler (Handler),
    SomeAsyncException,
    SomeException,
    catch,
    catches,
    handle,
    throw,
  )
import Control.Monad.State.Strict
  ( MonadIO (..),
    MonadState (get),
    StateT (runStateT),
    modify',
  )
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Dependent.Map as DM
import Data.Dynamic (Dynamic (..))
import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import qualified Data.Vinyl.Functor as V
import GHC.Generics ((:*:) (..))
import Roboservant.Types
  ( ApiOffset (..),
    Argument (..),
    InteractionError(..),
    Provenance (..),
    ReifiedApi,
    ReifiedEndpoint (..),
    Stash (..),
    StashValue (..),
    TypedF,
  )
import Roboservant.Types.Config

import System.Random (Random (randomR), StdGen, mkStdGen)
import qualified Type.Reflection as R

data RoboservantException
  = RoboservantException
      { RoboservantException -> FailureType
failureReason :: FailureType,
        RoboservantException -> Maybe SomeException
serverException :: Maybe SomeException,
        RoboservantException -> FuzzState
fuzzState :: FuzzState
      }
  deriving (Int -> RoboservantException -> ShowS
[RoboservantException] -> ShowS
RoboservantException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoboservantException] -> ShowS
$cshowList :: [RoboservantException] -> ShowS
show :: RoboservantException -> String
$cshow :: RoboservantException -> String
showsPrec :: Int -> RoboservantException -> ShowS
$cshowsPrec :: Int -> RoboservantException -> ShowS
Show)

instance Exception RoboservantException

data FailureType
  = ServerCrashed
  | CheckerFailed
  | NoPossibleMoves
  | InsufficientCoverage Double
  deriving (Int -> FailureType -> ShowS
[FailureType] -> ShowS
FailureType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureType] -> ShowS
$cshowList :: [FailureType] -> ShowS
show :: FailureType -> String
$cshow :: FailureType -> String
showsPrec :: Int -> FailureType -> ShowS
$cshowsPrec :: Int -> FailureType -> ShowS
Show, FailureType -> FailureType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureType -> FailureType -> Bool
$c/= :: FailureType -> FailureType -> Bool
== :: FailureType -> FailureType -> Bool
$c== :: FailureType -> FailureType -> Bool
Eq)

data FuzzOp
  = FuzzOp
      { FuzzOp -> ApiOffset
apiOffset :: ApiOffset,
        FuzzOp -> [Provenance]
provenance :: [Provenance]
      }
  deriving (Int -> FuzzOp -> ShowS
[FuzzOp] -> ShowS
FuzzOp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FuzzOp] -> ShowS
$cshowList :: [FuzzOp] -> ShowS
show :: FuzzOp -> String
$cshow :: FuzzOp -> String
showsPrec :: Int -> FuzzOp -> ShowS
$cshowsPrec :: Int -> FuzzOp -> ShowS
Show, FuzzOp -> FuzzOp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FuzzOp -> FuzzOp -> Bool
$c/= :: FuzzOp -> FuzzOp -> Bool
== :: FuzzOp -> FuzzOp -> Bool
$c== :: FuzzOp -> FuzzOp -> Bool
Eq)

data FuzzState
  = FuzzState
      { FuzzState -> [FuzzOp]
path :: [FuzzOp],
        FuzzState -> Stash
stash :: Stash,
        FuzzState -> StdGen
currentRng :: StdGen
      }
  deriving (Int -> FuzzState -> ShowS
[FuzzState] -> ShowS
FuzzState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FuzzState] -> ShowS
$cshowList :: [FuzzState] -> ShowS
show :: FuzzState -> String
$cshow :: FuzzState -> String
showsPrec :: Int -> FuzzState -> ShowS
$cshowsPrec :: Int -> FuzzState -> ShowS
Show)

data EndpointOption
  = forall as.
    (V.RecordToList as, V.RMap as) =>
    EndpointOption
      { ()
eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
        ()
eoArgs :: V.Rec (TypedF StashValue) as
      }

data StopReason
  = TimedOut
  | HitMaxIterations
  deriving (Int -> StopReason -> ShowS
[StopReason] -> ShowS
StopReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StopReason] -> ShowS
$cshowList :: [StopReason] -> ShowS
show :: StopReason -> String
$cshow :: StopReason -> String
showsPrec :: Int -> StopReason -> ShowS
$cshowsPrec :: Int -> StopReason -> ShowS
Show, StopReason -> StopReason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StopReason -> StopReason -> Bool
$c/= :: StopReason -> StopReason -> Bool
== :: StopReason -> StopReason -> Bool
$c== :: StopReason -> StopReason -> Bool
Eq)

data Report
  = Report
      { Report -> String
textual :: String,
        Report -> RoboservantException
rsException :: RoboservantException
      }
  deriving (Int -> Report -> ShowS
[Report] -> ShowS
Report -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Report] -> ShowS
$cshowList :: [Report] -> ShowS
show :: Report -> String
$cshow :: Report -> String
showsPrec :: Int -> Report -> ShowS
$cshowsPrec :: Int -> Report -> ShowS
Show)



-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
-- fuzzClient = undefined



fuzz' ::
  ReifiedApi ->
  Config ->
  IO (Maybe Report)
fuzz' :: ReifiedApi -> Config -> IO (Maybe Report)
fuzz' ReifiedApi
reifiedApi Config {Double
Int
Integer
[(Dynamic, Int)]
IO ()
String -> IO ()
healthCheck :: Config -> IO ()
logInfo :: Config -> String -> IO ()
coverageThreshold :: Config -> Double
rngSeed :: Config -> Int
maxReps :: Config -> Integer
maxRuntime :: Config -> Double
seed :: Config -> [(Dynamic, Int)]
healthCheck :: IO ()
logInfo :: String -> IO ()
coverageThreshold :: Double
rngSeed :: Int
maxReps :: Integer
maxRuntime :: Double
seed :: [(Dynamic, Int)]
..} = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoboservantException -> Report
formatException) forall a b. (a -> b) -> a -> b
$ do
  let path :: [a]
path = []
      stash :: Stash
stash = [(Dynamic, Int)] -> Stash -> Stash
addToStash [(Dynamic, Int)]
seed forall a. Monoid a => a
mempty
      currentRng :: StdGen
currentRng = Int -> StdGen
mkStdGen Int
rngSeed
  UTCTime
deadline :: UTCTime <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ Double
maxRuntime forall a. Num a => a -> a -> a
* Double
1000000) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  (StopReason
stopreason, FuzzState
_fs) <-
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      (forall (m :: * -> *) a.
MonadIO m =>
(Integer, UTCTime) -> m a -> m StopReason
untilDone (Integer
maxReps, UTCTime
deadline) forall (m :: * -> *).
(MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
m ()
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (FuzzState -> StateT FuzzState IO ()
evaluateCoverage forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get))
      FuzzState {StdGen
Stash
forall a. [a]
currentRng :: StdGen
stash :: Stash
path :: forall a. [a]
currentRng :: StdGen
stash :: Stash
path :: [FuzzOp]
..}
  String -> IO ()
logInfo forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show StopReason
stopreason
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  where
    -- something less terrible later
    formatException :: RoboservantException -> Report
    formatException :: RoboservantException -> Report
formatException r :: RoboservantException
r@(RoboservantException FailureType
failureType Maybe SomeException
exception FuzzState
_state) =
      String -> RoboservantException -> Report
Report
        ([String] -> String
unlines [forall a. Show a => a -> String
show FailureType
failureType, forall a. Show a => a -> String
show Maybe SomeException
exception])
        RoboservantException
r
    displayDiagnostics :: FuzzState -> StateT FuzzState IO ()
displayDiagnostics FuzzState {[FuzzOp]
StdGen
Stash
currentRng :: StdGen
stash :: Stash
path :: [FuzzOp]
currentRng :: FuzzState -> StdGen
stash :: FuzzState -> Stash
path :: FuzzState -> [FuzzOp]
..} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      String -> IO ()
logInfo forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      [String
"api endpoints covered"]
        forall a. Semigroup a => a -> a -> a
<> (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FuzzOp -> ApiOffset
apiOffset [FuzzOp]
path)
        forall a. Semigroup a => a -> a -> a
<> [String
"", String
"types in stash"]
        forall a. Semigroup a => a -> a -> a
<> forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) b.
(forall (v :: k1). k2 v -> f v -> b -> b) -> b -> DMap k2 f -> b
DM.foldrWithKey (\TypeRep v
_ StashValue v
v [String]
r -> (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> Int
NEL.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StashValue a -> NonEmpty ([Provenance], a)
getStashValue forall a b. (a -> b) -> a -> b
$ StashValue v
v) forall a. a -> [a] -> [a]
: [String]
r) [] (Stash -> DMap TypeRep StashValue
getStash Stash
stash)
    --        <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
    --        $ \_k v ->
    --               (show . NEL.length $ getStashValue v))

    evaluateCoverage :: FuzzState -> StateT FuzzState IO ()
evaluateCoverage f :: FuzzState
f@FuzzState {[FuzzOp]
StdGen
Stash
currentRng :: StdGen
stash :: Stash
path :: [FuzzOp]
currentRng :: FuzzState -> StdGen
stash :: FuzzState -> Stash
path :: FuzzState -> [FuzzOp]
..}
      | Double
coverage forall a. Ord a => a -> a -> Bool
> Double
coverageThreshold = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        FuzzState -> StateT FuzzState IO ()
displayDiagnostics FuzzState
f
        forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ FailureType
-> Maybe SomeException -> FuzzState -> RoboservantException
RoboservantException (Double -> FailureType
InsufficientCoverage Double
coverage) forall a. Maybe a
Nothing FuzzState
f
      where
        hitRoutes :: Double
hitRoutes = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FuzzOp -> ApiOffset
apiOffset [FuzzOp]
path
        totalRoutes :: Double
totalRoutes = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
routeCount
        coverage :: Double
coverage = Double
hitRoutes forall a. Fractional a => a -> a -> a
/ Double
totalRoutes
    untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
    untilDone :: forall (m :: * -> *) a.
MonadIO m =>
(Integer, UTCTime) -> m a -> m StopReason
untilDone (Integer
0, UTCTime
_) m a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure StopReason
HitMaxIterations
    untilDone (Integer
n, UTCTime
deadline) m a
action = do
      UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      if UTCTime
now forall a. Ord a => a -> a -> Bool
> UTCTime
deadline
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure StopReason
TimedOut
        else do
          a
_ <- m a
action
          forall (m :: * -> *) a.
MonadIO m =>
(Integer, UTCTime) -> m a -> m StopReason
untilDone (Integer
n forall a. Num a => a -> a -> a
-Integer
1, UTCTime
deadline) m a
action

    routeCount :: Int
routeCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length ReifiedApi
reifiedApi
    elementOrFail ::
      (MonadState FuzzState m, MonadIO m) =>
      [a] ->
      m a
    elementOrFail :: forall (m :: * -> *) a.
(MonadState FuzzState m, MonadIO m) =>
[a] -> m a
elementOrFail [] = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureType
-> Maybe SomeException -> FuzzState -> RoboservantException
RoboservantException FailureType
NoPossibleMoves forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
    elementOrFail [a]
l = do
      FuzzState
st <- forall s (m :: * -> *). MonadState s m => m s
get
      let (Int
index, StdGen
newGen) = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Num a => a -> a -> a
- Int
1) (FuzzState -> StdGen
currentRng FuzzState
st)
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \FuzzState
st' -> FuzzState
st' {currentRng :: StdGen
currentRng = StdGen
newGen}
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
l forall a. [a] -> Int -> a
!! Int
index)
    withOp ::
      (MonadState FuzzState m, MonadIO m) =>
      ( forall as.
        (V.RecordToList as, V.RMap as) =>
        FuzzOp ->
        V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
        V.Rec (TypedF V.Identity) as ->
        m r
      ) ->
      m r
    withOp :: forall (m :: * -> *) r.
(MonadState FuzzState m, MonadIO m) =>
(forall (as :: [*]).
 (RecordToList as, RMap as) =>
 FuzzOp
 -> Curried
      as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
 -> Rec (TypedF Identity) as
 -> m r)
-> m r
withOp forall (as :: [*]).
(RecordToList as, RMap as) =>
FuzzOp
-> Curried
     as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Rec (TypedF Identity) as
-> m r
callback = do
      -- choose a call to make, from the endpoints with fillable arguments.
      (ApiOffset
offset, EndpointOption {Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
Rec (TypedF StashValue) as
eoArgs :: Rec (TypedF StashValue) as
eoCall :: Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
eoArgs :: ()
eoCall :: ()
..}) <- forall (m :: * -> *) a.
(MonadState FuzzState m, MonadIO m) =>
[a] -> m a
elementOrFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. FuzzState -> [(ApiOffset, EndpointOption)]
options forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
      Rec (Const Int :*: (TypeRep :*: (,) [Provenance])) as
r <-
        forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
V.rtraverse
          ( \(TypeRep x
tr :*: StashValue NonEmpty ([Provenance], x)
svs IntSet
_) ->
              forall (m :: * -> *) a.
(MonadState FuzzState m, MonadIO m) =>
[a] -> m a
elementOrFail forall a b. (a -> b) -> a -> b
$
                forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                  (\Int
i ([Provenance], x)
xy -> forall k a (b :: k). a -> Const a b
V.Const Int
i forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: TypeRep x
tr forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: ([Provenance], x)
xy)
                  [Int
0 ..]
                  (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty ([Provenance], x)
svs)
          )
          Rec (TypedF StashValue) as
eoArgs
      let pathSegment :: FuzzOp
pathSegment =
            ApiOffset -> [Provenance] -> FuzzOp
FuzzOp ApiOffset
offset forall a b. (a -> b) -> a -> b
$
              forall {u} (as :: [u]) (f :: u -> *) a.
(RecordToList as, RMap as) =>
(forall (x :: u). f x -> a) -> Rec f as -> [a]
recordToList'
                (\(V.Const Int
index :*: TypeRep x
tr :*: ([Provenance], x)
_) -> SomeTypeRep -> Int -> Provenance
Provenance (forall k (a :: k). TypeRep a -> SomeTypeRep
R.SomeTypeRep TypeRep x
tr) Int
index)
                Rec (Const Int :*: (TypeRep :*: (,) [Provenance])) as
r
          argValues :: Rec (TypedF Identity) as
argValues =
            forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
V.rmap
              (\(Const Int x
_ :*: TypeRep x
tr :*: ([Provenance]
_, x
x)) -> TypeRep x
tr forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall a. a -> Identity a
V.Identity x
x)
              Rec (Const Int :*: (TypeRep :*: (,) [Provenance])) as
r
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\FuzzState
f -> FuzzState
f {path :: [FuzzOp]
path = FuzzState -> [FuzzOp]
path FuzzState
f forall a. Semigroup a => a -> a -> a
<> [FuzzOp
pathSegment]})
      forall (as :: [*]).
(RecordToList as, RMap as) =>
FuzzOp
-> Curried
     as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Rec (TypedF Identity) as
-> m r
callback FuzzOp
pathSegment Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
eoCall Rec (TypedF Identity) as
argValues
      where
        options :: FuzzState -> [(ApiOffset, EndpointOption)]
        options :: FuzzState -> [(ApiOffset, EndpointOption)]
options FuzzState {[FuzzOp]
StdGen
Stash
currentRng :: StdGen
stash :: Stash
path :: [FuzzOp]
currentRng :: FuzzState -> StdGen
stash :: FuzzState -> Stash
path :: FuzzState -> [FuzzOp]
..} =
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            ( \(ApiOffset
offset, ReifiedEndpoint {Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
Rec (TypedF Argument) as
reEndpointFunc :: ()
reArguments :: ()
reEndpointFunc :: Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
reArguments :: Rec (TypedF Argument) as
..}) -> do
                Rec (TypedF StashValue) as
args <- forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
V.rtraverse (\(TypeRep x
tr :*: Argument Stash -> Maybe (StashValue x)
bf) -> (TypeRep x
tr forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stash -> Maybe (StashValue x)
bf Stash
stash) Rec (TypedF Argument) as
reArguments
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApiOffset
offset, forall (as :: [*]).
(RecordToList as, RMap as) =>
Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Rec (TypedF StashValue) as -> EndpointOption
EndpointOption Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
reEndpointFunc Rec (TypedF StashValue) as
args)
            )
            ReifiedApi
reifiedApi
    execute ::
      (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
      FuzzOp ->
      V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
      V.Rec (TypedF V.Identity) as ->
      m ()
    execute :: forall (m :: * -> *) (as :: [*]).
(MonadState FuzzState m, MonadIO m, RecordToList as, RMap as) =>
FuzzOp
-> Curried
     as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Rec (TypedF Identity) as
-> m ()
execute FuzzOp
fuzzop Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
func Rec (TypedF Identity) as
args = do
      (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FuzzOp
fuzzop,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FuzzState -> Stash
stash) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (ts :: [*]) a. Curried ts a -> Rec Identity ts -> a
V.runcurry' Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
func Rec Identity as
argVals) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left (InteractionError
e::InteractionError) ->
          if InteractionError -> Bool
fatalError InteractionError
e
          then forall a e. Exception e => e -> a
throw InteractionError
e
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right (NonEmpty (Dynamic, Int)
dyn :: NEL.NonEmpty (Dynamic, Int)) ->
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'
          ( \fs :: FuzzState
fs@FuzzState {[FuzzOp]
StdGen
Stash
currentRng :: StdGen
stash :: Stash
path :: [FuzzOp]
currentRng :: FuzzState -> StdGen
stash :: FuzzState -> Stash
path :: FuzzState -> [FuzzOp]
..} ->
              FuzzState
fs {stash :: Stash
stash = [(Dynamic, Int)] -> Stash -> Stash
addToStash (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Dynamic, Int)
dyn) Stash
stash}
          )
      where
        argVals :: Rec Identity as
argVals = forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
V.rmap (\(TypeRep x
_ :*: V.Identity x
x) -> forall a. a -> Identity a
V.Identity x
x) Rec (TypedF Identity) as
args
    -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
    go ::
      (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
      m ()
    go :: forall (m :: * -> *).
(MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
m ()
go = forall (m :: * -> *) r.
(MonadState FuzzState m, MonadIO m) =>
(forall (as :: [*]).
 (RecordToList as, RMap as) =>
 FuzzOp
 -> Curried
      as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
 -> Rec (TypedF Identity) as
 -> m r)
-> m r
withOp forall a b. (a -> b) -> a -> b
$ \FuzzOp
op Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
func Rec (TypedF Identity) as
args -> do
      forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
catches
        (forall (m :: * -> *) (as :: [*]).
(MonadState FuzzState m, MonadIO m, RecordToList as, RMap as) =>
FuzzOp
-> Curried
     as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Rec (TypedF Identity) as
-> m ()
execute FuzzOp
op Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
func Rec (TypedF Identity) as
args)
        [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(SomeAsyncException
e :: SomeAsyncException) -> forall a e. Exception e => e -> a
throw SomeAsyncException
e),
          forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler
            ( \(SomeException
e :: SomeException) -> 
                forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureType
-> Maybe SomeException -> FuzzState -> RoboservantException
RoboservantException FailureType
ServerCrashed (forall a. a -> Maybe a
Just SomeException
e) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
            )
        ]
      forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
        (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
healthCheck)
        (\(SomeException
e :: SomeException) -> forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureType
-> Maybe SomeException -> FuzzState -> RoboservantException
RoboservantException FailureType
CheckerFailed (forall a. a -> Maybe a
Just SomeException
e) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get)

addToStash ::
  [(Dynamic, Int)] ->
  Stash ->
  Stash
addToStash :: [(Dynamic, Int)] -> Stash -> Stash
addToStash [(Dynamic, Int)]
result Stash
stash =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    ( \(Dynamic TypeRep a
tr a
x, Int
hashed) (Stash DMap TypeRep StashValue
dict) ->
        DMap TypeRep StashValue -> Stash
Stash forall a b. (a -> b) -> a -> b
$
          forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
(f v -> f v -> f v) -> k2 v -> f v -> DMap k2 f -> DMap k2 f
DM.insertWith
            forall a. StashValue a -> StashValue a -> StashValue a
renumber
            TypeRep a
tr
            (forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue (([SomeTypeRep -> Int -> Provenance
Provenance (forall k (a :: k). TypeRep a -> SomeTypeRep
R.SomeTypeRep TypeRep a
tr) Int
0], a
x) forall a. a -> [a] -> NonEmpty a
:| []) (Int -> IntSet
IntSet.singleton Int
hashed))
            DMap TypeRep StashValue
dict
    )
    Stash
stash
    [(Dynamic, Int)]
result
  where
    renumber ::
      StashValue a ->
      StashValue a ->
      StashValue a
    renumber :: forall a. StashValue a -> StashValue a -> StashValue a
renumber (StashValue NonEmpty ([Provenance], a)
singleDyn IntSet
singleHash) orig :: StashValue a
orig@(StashValue NonEmpty ([Provenance], a)
l IntSet
intSet)
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
IntSet.null (IntSet
singleHash IntSet -> IntSet -> IntSet
`IntSet.intersection` IntSet
intSet) = StashValue a
orig
      | Bool
otherwise =
        forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue
          ( case forall a. NonEmpty a -> [a]
NEL.toList NonEmpty ([Provenance], a)
singleDyn of
              [([Provenance SomeTypeRep
tr Int
_], a
dyn)] ->
                NonEmpty ([Provenance], a)
l forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SomeTypeRep -> Int -> Provenance
Provenance SomeTypeRep
tr (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. NonEmpty a -> a
NEL.last NonEmpty ([Provenance], a)
l) forall a. Num a => a -> a -> a
+ Int
1)], a
dyn)
              [([Provenance], a)]
_ -> forall a. HasCallStack => String -> a
error String
"should be impossible"
          )
          (IntSet -> IntSet -> IntSet
IntSet.union IntSet
singleHash IntSet
intSet)

-- why isn't this in vinyl?
recordToList' ::
  (V.RecordToList as, V.RMap as) =>
  (forall x. f x -> a) ->
  V.Rec f as ->
  [a]
recordToList' :: forall {u} (as :: [u]) (f :: u -> *) a.
(RecordToList as, RMap as) =>
(forall (x :: u). f x -> a) -> Rec f as -> [a]
recordToList' forall (x :: u). f x -> a
f = forall {u} (rs :: [u]) a.
RecordToList rs =>
Rec (Const a) rs -> [a]
V.recordToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
V.rmap (forall k a (b :: k). a -> Const a b
V.Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (x :: u). f x -> a
f)