{-# LANGUAGE LambdaCase #-}

module Futhark.Test.Property
  ( runPBT,
    PBTConfig (..),
    PBTPhase (..),
    PropSpec (..),
    PBTOutput,
    PBTFailure,
    extractPropSpecs,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Except
import Data.Either (fromRight, partitionEithers)
import Data.IORef
import Data.Int
import Data.List qualified as L
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Text qualified as T
import Data.Word (Word64)
import Futhark.Data
import Futhark.Server
import Futhark.Server.Values qualified as FSV
import Futhark.Test.Values
  ( RandomConfiguration (..),
    initialRandomConfiguration,
    randomValue,
  )
import Futhark.Util (showText)
import System.FilePath (dropExtension)
import System.Random (StdGen, mkStdGen, random)
import System.Random.Stateful (IOGenM (..), applyIOGen, newIOGenM)

-- | Configuration for property-based testing.
-- Includes parameters for test case generation, shrinking, and random seed management.
data PBTConfig = PBTConfig
  { -- | Number of test cases to run for each property.
    PBTConfig -> Int32
configNumTests :: Int32,
    -- | Maximum size argument to pass to generators and shrinkers (unless
    -- overridden by PropSpec).
    PBTConfig -> Int64
configMaxSize :: Int64,
    -- | Seed to use for the random number generator (can be overridden by PropSpec).
    PBTConfig -> Word64
configSeed :: Word64,
    -- | Number of shrinking attempts to make on userdefined shrinker before
    -- giving up and reporting the current candidate as the final
    -- counterexample.
    PBTConfig -> Int
configShrinkTries :: Int
  }
  deriving (Int -> PBTConfig -> ShowS
[PBTConfig] -> ShowS
PBTConfig -> String
(Int -> PBTConfig -> ShowS)
-> (PBTConfig -> String)
-> ([PBTConfig] -> ShowS)
-> Show PBTConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBTConfig -> ShowS
showsPrec :: Int -> PBTConfig -> ShowS
$cshow :: PBTConfig -> String
show :: PBTConfig -> String
$cshowList :: [PBTConfig] -> ShowS
showList :: [PBTConfig] -> ShowS
Show, PBTConfig -> PBTConfig -> Bool
(PBTConfig -> PBTConfig -> Bool)
-> (PBTConfig -> PBTConfig -> Bool) -> Eq PBTConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PBTConfig -> PBTConfig -> Bool
== :: PBTConfig -> PBTConfig -> Bool
$c/= :: PBTConfig -> PBTConfig -> Bool
/= :: PBTConfig -> PBTConfig -> Bool
Eq)

-- | Specification for a property to be tested, including the property entry point and
-- optional generator and shrinker entry points, as well as an optional size parameter.
data PropSpec = PropSpec
  { -- | The property entry point to test.
    PropSpec -> Text
psProp :: T.Text,
    -- | Optional generator entry point to use instead of the default
    -- auto-generator.
    PropSpec -> Maybe Text
psGen :: Maybe T.Text,
    -- | Optional shrinker entry point to use instead of the default
    -- auto-shrinker.
    PropSpec -> Maybe Text
psShrink :: Maybe T.Text,
    -- | Optional size argument to pass to the generator and shrinker phases
    -- (overrides 'configMaxSize').
    PropSpec -> Maybe Int64
psSize :: Maybe Int64
  }
  deriving (Int -> PropSpec -> ShowS
[PropSpec] -> ShowS
PropSpec -> String
(Int -> PropSpec -> ShowS)
-> (PropSpec -> String) -> ([PropSpec] -> ShowS) -> Show PropSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PropSpec -> ShowS
showsPrec :: Int -> PropSpec -> ShowS
$cshow :: PropSpec -> String
show :: PropSpec -> String
$cshowList :: [PropSpec] -> ShowS
showList :: [PropSpec] -> ShowS
Show, PropSpec -> PropSpec -> Bool
(PropSpec -> PropSpec -> Bool)
-> (PropSpec -> PropSpec -> Bool) -> Eq PropSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PropSpec -> PropSpec -> Bool
== :: PropSpec -> PropSpec -> Bool
$c/= :: PropSpec -> PropSpec -> Bool
/= :: PropSpec -> PropSpec -> Bool
Eq)

-- | Information about the current phase of property-based testing,
-- used for logging and debugging.
data PBTPhase = PBTPhase
  { -- | Property being tested (same for generator and shrinker phases).
    PBTPhase -> Maybe Text
activeTest :: Maybe EntryName,
    -- | Current entrypoint being called (property, generator, or shrinker).
    PBTPhase -> Maybe Text
phase :: Maybe EntryName,
    -- | Property or generator (only for auto).
    PBTPhase -> Maybe Text
shrinkWith :: Maybe EntryName,
    -- | Size argument for generator and shrinker phases.
    PBTPhase -> Maybe Int64
phaseSize :: Maybe Int64,
    -- | Seed argument for generator and shrinker phases.
    PBTPhase -> Maybe Word64
phaseSeed :: Maybe Word64,
    -- | Random value argument for shrinker phase (used for user-defined
    -- shrinker, otherwise 'Nothing').
    PBTPhase -> Maybe Word64
phaseRandom :: Maybe Word64
  }
  deriving (Int -> PBTPhase -> ShowS
[PBTPhase] -> ShowS
PBTPhase -> String
(Int -> PBTPhase -> ShowS)
-> (PBTPhase -> String) -> ([PBTPhase] -> ShowS) -> Show PBTPhase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBTPhase -> ShowS
showsPrec :: Int -> PBTPhase -> ShowS
$cshow :: PBTPhase -> String
show :: PBTPhase -> String
$cshowList :: [PBTPhase] -> ShowS
showList :: [PBTPhase] -> ShowS
Show, PBTPhase -> PBTPhase -> Bool
(PBTPhase -> PBTPhase -> Bool)
-> (PBTPhase -> PBTPhase -> Bool) -> Eq PBTPhase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PBTPhase -> PBTPhase -> Bool
== :: PBTPhase -> PBTPhase -> Bool
$c/= :: PBTPhase -> PBTPhase -> Bool
/= :: PBTPhase -> PBTPhase -> Bool
Eq)

-- | Output of a property-based test run, which is either a failure with
-- an error message or a success.
type PBTOutput = Maybe T.Text

-- | Failure in property-based testing, represented as an error message.
-- For example a division by zero runtime error.
type PBTFailure = T.Text

-- | The Haskell-level random number generator that we use for generating seeds
-- passed to generators.
type PBTGen = IOGenM StdGen

genWord64 :: (MonadIO m) => PBTGen -> m Word64
genWord64 :: forall (m :: * -> *). MonadIO m => PBTGen -> m Word64
genWord64 = (StdGen -> (Word64, StdGen)) -> PBTGen -> m Word64
forall (m :: * -> *) g a.
MonadIO m =>
(g -> (a, g)) -> IOGenM g -> m a
applyIOGen StdGen -> (Word64, StdGen)
forall g. RandomGen g => g -> (Word64, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random

-- | For unexcpected critical errors
unexpectedFailure :: (MonadFail m) => T.Text -> m a
unexpectedFailure :: forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure Text
msg =
  String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
    String
"Unexpected critical error: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
msg
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nProbably a bug please report as issue on the GitHub repository."

lookupArgText :: T.Text -> [T.Text] -> Maybe T.Text
lookupArgText :: Text -> [Text] -> Maybe Text
lookupArgText Text
name = Text -> (Text -> Maybe Text) -> [Text] -> Maybe Text
forall a. Text -> (Text -> Maybe a) -> [Text] -> Maybe a
lookupArgWith Text
name Text -> Maybe Text
forall a. a -> Maybe a
Just

lookupArgRead :: (Read a) => T.Text -> [T.Text] -> Maybe a
lookupArgRead :: forall a. Read a => Text -> [Text] -> Maybe a
lookupArgRead Text
name = Text -> (Text -> Maybe a) -> [Text] -> Maybe a
forall a. Text -> (Text -> Maybe a) -> [Text] -> Maybe a
lookupArgWith Text
name Text -> Maybe a
forall a. Read a => Text -> Maybe a
readMaybeText

lookupArgWith :: T.Text -> (T.Text -> Maybe a) -> [T.Text] -> Maybe a
lookupArgWith :: forall a. Text -> (Text -> Maybe a) -> [Text] -> Maybe a
lookupArgWith Text
name Text -> Maybe a
f = [Maybe a] -> Maybe a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe a] -> Maybe a)
-> ([Text] -> [Maybe a]) -> [Text] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe a) -> [Text] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
stripCall Text
name (Text -> Maybe Text) -> (Text -> Maybe a) -> Text -> Maybe a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Maybe a
f)

stripCall :: T.Text -> T.Text -> Maybe T.Text
stripCall :: Text -> Text -> Maybe Text
stripCall Text
name Text
t =
  let s :: Text
s = Text -> Text
T.strip Text
t
   in if Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
        then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
        else Text -> Text -> Maybe Text
T.stripSuffix Text
")" (Text -> Maybe Text) -> (Text -> Maybe Text) -> Text -> Maybe Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Text -> Maybe Text
T.stripPrefix (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(") (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
s

readMaybeText :: (Read a) => T.Text -> Maybe a
readMaybeText :: forall a. Read a => Text -> Maybe a
readMaybeText Text
t =
  case ReadS a
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
t) of
    [(a
x, String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

parsePropSpec :: T.Text -> T.Text -> Maybe PropSpec
parsePropSpec :: Text -> Text -> Maybe PropSpec
parsePropSpec Text
entry Text
attr = do
  argsText <- Text -> Text -> Maybe Text
stripCall Text
"prop" Text
attr
  let args = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," Text
argsText
  pure
    PropSpec
      { psProp = entry,
        psGen = lookupArgText "gen" args,
        psShrink = lookupArgText "shrink" args,
        psSize = fromInteger <$> lookupArgRead "size" args
      }

getPropAttrs :: T.Text -> [T.Text] -> [PropSpec]
getPropAttrs :: Text -> [Text] -> [PropSpec]
getPropAttrs Text
entry = (Text -> Maybe PropSpec) -> [Text] -> [PropSpec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Text -> Maybe PropSpec) -> [Text] -> [PropSpec])
-> (Text -> Maybe PropSpec) -> [Text] -> [PropSpec]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe PropSpec
parsePropSpec Text
entry

getInputTypes :: Server -> EntryName -> IO [TypeName]
getInputTypes :: Server -> Text -> IO [Text]
getInputTypes Server
srv Text
entry =
  ([InputType] -> [Text]) -> IO [InputType] -> IO [Text]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InputType -> Text) -> [InputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType) (IO [InputType] -> IO [Text]) -> IO [InputType] -> IO [Text]
forall a b. (a -> b) -> a -> b
$
    Text -> IO (Either CmdFailure [InputType]) -> IO [InputType]
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE (Text
"Failed to get input types for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (IO (Either CmdFailure [InputType]) -> IO [InputType])
-> IO (Either CmdFailure [InputType]) -> IO [InputType]
forall a b. (a -> b) -> a -> b
$
      Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
srv Text
entry

getOutputType :: Server -> EntryName -> IO TypeName
getOutputType :: Server -> Text -> IO Text
getOutputType Server
s Text
entry =
  (OutputType -> Text) -> IO OutputType -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OutputType -> Text
outputType (IO OutputType -> IO Text) -> IO OutputType -> IO Text
forall a b. (a -> b) -> a -> b
$
    Text -> IO (Either CmdFailure OutputType) -> IO OutputType
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE (Text
"Failed to get output types for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (IO (Either CmdFailure OutputType) -> IO OutputType)
-> IO (Either CmdFailure OutputType) -> IO OutputType
forall a b. (a -> b) -> a -> b
$
      Server -> Text -> IO (Either CmdFailure OutputType)
cmdOutput Server
s Text
entry

validateGenTypes :: Server -> EntryName -> Maybe EntryName -> IO (Maybe PBTFailure)
validateGenTypes :: Server -> Text -> Maybe Text -> IO (Maybe Text)
validateGenTypes Server
_srv Text
_prop_name Maybe Text
Nothing = Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
validateGenTypes Server
srv Text
prop_name (Just Text
gen_name) = (Either Text () -> Maybe Text)
-> IO (Either Text ()) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (() -> Maybe Text) -> Either Text () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (IO (Either Text ()) -> IO (Maybe Text))
-> (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO ()
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Maybe Text))
-> ExceptT Text IO () -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
  gen_ins <- IO [Text] -> ExceptT Text IO [Text]
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> ExceptT Text IO [Text])
-> IO [Text] -> ExceptT Text IO [Text]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO [Text]
getInputTypes Server
srv Text
gen_name
  gen_out <- liftIO $ getOutputType srv gen_name

  -- check expected output type for generator matches property input type
  test_ty <-
    liftIO (getSingleInputType srv prop_name) >>= \case
      Left Text
err -> Text -> ExceptT Text IO Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO Text) -> Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
showText Text
err
      Right Text
ty -> Text -> ExceptT Text IO Text
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ty

  let actual_tys = [Text]
gen_ins [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
gen_out]
      expected_tys = [Text
"i64", Text
"u64", Text
test_ty]

  unless (actual_tys == expected_tys) $
    throwE $
      ("Generator \"" <> gen_name <> "\" for property \"" <> prop_name <> "\" has invalid type.\n")
        <> ("Expected: " <> T.intercalate " -> " expected_tys <> "\n")
        <> ("Actual:   " <> T.intercalate " -> " actual_tys)

validateShrinkTypes :: Server -> EntryName -> EntryName -> IO (Maybe PBTFailure)
validateShrinkTypes :: Server -> Text -> Text -> IO (Maybe Text)
validateShrinkTypes Server
srv Text
propName Text
shrinkName = (Either Text () -> Maybe Text)
-> IO (Either Text ()) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (() -> Maybe Text) -> Either Text () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (IO (Either Text ()) -> IO (Maybe Text))
-> (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO ()
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Maybe Text))
-> ExceptT Text IO () -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
  propTy <-
    IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> IO (Either Text Text)
getSingleInputType Server
srv Text
propName) ExceptT Text IO (Either Text Text)
-> (Either Text Text -> ExceptT Text IO Text)
-> ExceptT Text IO Text
forall a b.
ExceptT Text IO a -> (a -> ExceptT Text IO b) -> ExceptT Text IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Text
err -> Text -> ExceptT Text IO Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO Text) -> Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
showText Text
err
      Right Text
ty -> Text -> ExceptT Text IO Text
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ty

  shrinkIns <- liftIO $ getInputTypes srv shrinkName

  -- validate input
  case shrinkIns of
    [Text
xTy, Text
randTy] -> do
      let errors :: [Text]
errors =
            [ Text
"Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" expects " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but shrinker " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shrinkName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" takes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
xTy
            | Text
xTy Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
propTy
            ]
              [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"Shrinker " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shrinkName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" takes random value " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
randTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but expected u64"
                 | Text
randTy Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"u64"
                 ]

      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
          Text
"Shrinker Mismatch:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n---\n" [Text]
errors
    [Text]
tys ->
      Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"Shrinker input arity mismatch.\n shrinker "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shrinkName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" inputs: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showText [Text]
tys
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nExpected exactly 2 inputs: ("
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propTy
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", u64)."

  -- validate output
  shrinkOut <- liftIO $ getOutputType srv shrinkName
  let isMatch = Text
propTy Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
shrinkOut

  unless isMatch $
    throwE $
      "Shrinker output mismatch.\nProperty "
        <> propName
        <> " expects: "
        <> propTy
        <> "\nShrinker "
        <> shrinkName
        <> " returns: "
        <> showText shrinkOut
        <> "\nExpected shrinker output to equal the property input type."

validatePropTypes :: Server -> EntryName -> IO (Maybe PBTFailure)
validatePropTypes :: Server -> Text -> IO (Maybe Text)
validatePropTypes Server
srv Text
propName = (Either Text () -> Maybe Text)
-> IO (Either Text ()) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (() -> Maybe Text) -> Either Text () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (IO (Either Text ()) -> IO (Maybe Text))
-> (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO ()
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Maybe Text))
-> ExceptT Text IO () -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
  ins <- IO [Text] -> ExceptT Text IO [Text]
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> ExceptT Text IO [Text])
-> IO [Text] -> ExceptT Text IO [Text]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO [Text]
getInputTypes Server
srv Text
propName
  case ins of
    [Text
_] -> () -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [] -> Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no inputs: expected 1."
    [Text]
_ -> Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ins) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" inputs; expected 1."

  out <- liftIO $ getOutputType srv propName
  case out of
    Text
"bool" -> () -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Text
ty -> Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" output must be bool, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty

validateOneSpec :: Server -> [EntryName] -> PropSpec -> ExceptT PBTFailure IO ()
validateOneSpec :: Server -> [Text] -> PropSpec -> ExceptT Text IO ()
validateOneSpec Server
srv [Text]
eps PropSpec
spec = do
  let prop :: Text
prop = PropSpec -> Text
psProp PropSpec
spec

  Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
prop Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
eps) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
      Text
"Property entry point not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prop

  IO (Maybe Text) -> ExceptT Text IO (Maybe Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> IO (Maybe Text)
validatePropTypes Server
srv Text
prop) ExceptT Text IO (Maybe Text)
-> (Maybe Text -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a b.
ExceptT Text IO a -> (a -> ExceptT Text IO b) -> ExceptT Text IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT Text IO ()
-> (Text -> ExceptT Text IO ()) -> Maybe Text -> ExceptT Text IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

  genName <- case PropSpec -> Maybe Text
psGen PropSpec
spec of
    Maybe Text
Nothing ->
      Maybe Text -> ExceptT Text IO (Maybe Text)
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just Text
g
      | Text
g Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
eps ->
          Text -> ExceptT Text IO (Maybe Text)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO (Maybe Text))
-> Text -> ExceptT Text IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text
"Generator is not a server entry point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
g
    Just Text
g ->
      Maybe Text -> ExceptT Text IO (Maybe Text)
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> ExceptT Text IO (Maybe Text))
-> Maybe Text -> ExceptT Text IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
g

  liftIO (validateGenTypes srv prop genName) >>= maybe (pure ()) throwE

  case psShrink spec of
    Maybe Text
Nothing -> () -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Text
sh -> do
      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
sh Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
eps) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
          Text
"Shrinker is not a server entry point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sh
      IO (Maybe Text) -> ExceptT Text IO (Maybe Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> Text -> IO (Maybe Text)
validateShrinkTypes Server
srv Text
prop Text
sh) ExceptT Text IO (Maybe Text)
-> (Maybe Text -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a b.
ExceptT Text IO a -> (a -> ExceptT Text IO b) -> ExceptT Text IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT Text IO ()
-> (Text -> ExceptT Text IO ()) -> Maybe Text -> ExceptT Text IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

-- | Extract property specifications from the server by looking for entry
-- points with #[prop(...)] attributes, comparing with the declared list of properties.
extractPropSpecs :: Server -> [EntryName] -> IO (Either PBTFailure [PropSpec])
extractPropSpecs :: Server -> [Text] -> IO (Either Text [PropSpec])
extractPropSpecs Server
srv [Text]
properties = do
  eps <- (CmdFailure -> IO [Text])
-> ([Text] -> IO [Text]) -> Either CmdFailure [Text] -> IO [Text]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO [Text]
forall a. HasCallStack => String -> a
error (String -> IO [Text])
-> (CmdFailure -> String) -> CmdFailure -> IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> String
forall a. Show a => a -> String
show) [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdFailure [Text] -> IO [Text])
-> (IO (Either CmdFailure [Text]) -> IO (Either CmdFailure [Text]))
-> IO (Either CmdFailure [Text])
-> IO [Text]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either CmdFailure [Text]) -> IO (Either CmdFailure [Text])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CmdFailure [Text]) -> IO [Text])
-> IO (Either CmdFailure [Text]) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ Server -> IO (Either CmdFailure [Text])
cmdEntryPoints Server
srv
  checks <- mapM (runExceptT . getOne eps) eps
  let missing = do
        f <- [Text]
properties
        guard $ f `L.notElem` eps
        pure $ Left $ "Declared as property, but is not an entry point: \"" <> f <> "\"."
  case partitionEithers $ checks ++ missing of
    ([], [Maybe PropSpec]
specs) -> Either Text [PropSpec] -> IO (Either Text [PropSpec])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text [PropSpec] -> IO (Either Text [PropSpec]))
-> Either Text [PropSpec] -> IO (Either Text [PropSpec])
forall a b. (a -> b) -> a -> b
$ [PropSpec] -> Either Text [PropSpec]
forall a b. b -> Either a b
Right ([PropSpec] -> Either Text [PropSpec])
-> [PropSpec] -> Either Text [PropSpec]
forall a b. (a -> b) -> a -> b
$ [Maybe PropSpec] -> [PropSpec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe PropSpec]
specs
    ([Text]
errors, [Maybe PropSpec]
_) -> Either Text [PropSpec] -> IO (Either Text [PropSpec])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text [PropSpec] -> IO (Either Text [PropSpec]))
-> Either Text [PropSpec] -> IO (Either Text [PropSpec])
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [PropSpec]
forall a b. a -> Either a b
Left (Text -> Either Text [PropSpec]) -> Text -> Either Text [PropSpec]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
errors
  where
    getOne :: [Text] -> Text -> ExceptT Text IO (Maybe PropSpec)
getOne [Text]
eps Text
entry = do
      attrs <-
        (CmdFailure -> ExceptT Text IO [Text])
-> ([Text] -> ExceptT Text IO [Text])
-> Either CmdFailure [Text]
-> ExceptT Text IO [Text]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> ExceptT Text IO [Text]
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> ExceptT Text IO [Text])
-> (CmdFailure -> Text) -> CmdFailure -> ExceptT Text IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> Text
forall a. Show a => a -> Text
showText) [Text] -> ExceptT Text IO [Text]
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdFailure [Text] -> ExceptT Text IO [Text])
-> (IO (Either CmdFailure [Text])
    -> ExceptT Text IO (Either CmdFailure [Text]))
-> IO (Either CmdFailure [Text])
-> ExceptT Text IO [Text]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either CmdFailure [Text])
-> ExceptT Text IO (Either CmdFailure [Text])
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CmdFailure [Text]) -> ExceptT Text IO [Text])
-> IO (Either CmdFailure [Text]) -> ExceptT Text IO [Text]
forall a b. (a -> b) -> a -> b
$
          Server -> Text -> IO (Either CmdFailure [Text])
cmdAttributes Server
srv Text
entry
      let specs = Text -> [Text] -> [PropSpec]
getPropAttrs Text
entry [Text]
attrs
          is_prop = Text
entry Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
properties
      case specs of
        [PropSpec
spec] | Bool
is_prop -> do
          Server -> [Text] -> PropSpec -> ExceptT Text IO ()
validateOneSpec Server
srv [Text]
eps PropSpec
spec
          Maybe PropSpec -> ExceptT Text IO (Maybe PropSpec)
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PropSpec -> ExceptT Text IO (Maybe PropSpec))
-> Maybe PropSpec -> ExceptT Text IO (Maybe PropSpec)
forall a b. (a -> b) -> a -> b
$ PropSpec -> Maybe PropSpec
forall a. a -> Maybe a
Just PropSpec
spec
        []
          | Bool
is_prop ->
              Text -> ExceptT Text IO (Maybe PropSpec)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO (Maybe PropSpec))
-> Text -> ExceptT Text IO (Maybe PropSpec)
forall a b. (a -> b) -> a -> b
$
                Text
"Entry point \""
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" declared as property, but has no #[prop(...)] attribute."
          | Bool
otherwise ->
              Maybe PropSpec -> ExceptT Text IO (Maybe PropSpec)
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PropSpec
forall a. Maybe a
Nothing
        [PropSpec]
_
          | Bool
is_prop ->
              Text -> ExceptT Text IO (Maybe PropSpec)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO (Maybe PropSpec))
-> Text -> ExceptT Text IO (Maybe PropSpec)
forall a b. (a -> b) -> a -> b
$
                Text
"Entry point \""
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" has more than one #[prop(...)] attribute."
          | Bool
otherwise ->
              Text -> ExceptT Text IO (Maybe PropSpec)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO (Maybe PropSpec))
-> Text -> ExceptT Text IO (Maybe PropSpec)
forall a b. (a -> b) -> a -> b
$
                Text
"Entry point \""
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" not declared as property, but has #[prop(...)] attribute."

-- | Generate a candidate automatically.
automaticGenerator :: Server -> EntryName -> TypeName -> Int64 -> PBTGen -> IO (Maybe PBTFailure)
automaticGenerator :: Server -> Text -> Text -> Int64 -> PBTGen -> IO (Maybe Text)
automaticGenerator Server
srv Text
candidate Text
genTy Int64
size PBTGen
rng = do
  kRes <- Text -> IO (Either CmdFailure Kind) -> IO Kind
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
"automaticGenerator cmdKind failed: " (IO (Either CmdFailure Kind) -> IO Kind)
-> IO (Either CmdFailure Kind) -> IO Kind
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure Kind)
cmdKind Server
srv Text
genTy
  case kRes of
    Kind
Record -> do
      resFields <- Server -> Text -> IO (Either CmdFailure [Field])
cmdFields Server
srv Text
genTy
      case resFields of
        Right [Field]
fields -> do
          let fieldVarNames :: [Text]
fieldVarNames = [Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_$compositeVal" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
fld | Field
fld <- [Field]
fields]

          results <- [(Text, Field)]
-> ((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Field] -> [(Text, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldVarNames [Field]
fields) (((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text])
-> ((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text]
forall a b. (a -> b) -> a -> b
$ \(Text
fVarName, Field
fld) ->
            Server -> Text -> Text -> Int64 -> PBTGen -> IO (Maybe Text)
automaticGenerator Server
srv Text
fVarName (Field -> Text
fieldType Field
fld) Int64
size PBTGen
rng

          case sequence results of
            Just [Text]
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
            Maybe [Text]
Nothing -> do
              Server -> [Text] -> IO ()
freeVars Server
srv [Text
candidate]
              Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM (Text
"Failed to pack record " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$
                Server -> Text -> Text -> [Text] -> IO (Maybe CmdFailure)
cmdNew Server
srv Text
candidate Text
genTy [Text]
fieldVarNames

              Server -> [Text] -> IO ()
freeVars Server
srv [Text]
fieldVarNames
              Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
        Left CmdFailure
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ CmdFailure -> Text
forall a. Show a => a -> Text
showText CmdFailure
err
    Kind
Array -> do
      (dimCount, baseTy) <- Server -> Text -> IO (Int, Text)
getArrayDimsAndBase Server
srv Text
genTy
      baseKind <- cmdErrorHandlerE "automaticGenerator base cmdKind failed: " $ cmdKind srv baseTy
      case baseKind of
        Kind
Record -> do
          resFields <- Server -> Text -> IO (Either CmdFailure [Field])
cmdFields Server
srv Text
baseTy
          case resFields of
            Right [Field]
fields -> do
              let fieldVarNames :: [Text]
fieldVarNames = [Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_$compositeArr_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
fld | Field
fld <- [Field]
fields]

              results <- [(Text, Field)]
-> ((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Field] -> [(Text, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldVarNames [Field]
fields) (((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text])
-> ((Text, Field) -> IO (Maybe Text)) -> IO [Maybe Text]
forall a b. (a -> b) -> a -> b
$ \(Text
fVarName, Field
fld) -> do
                (innerDimCount, innerBaseTy) <- Server -> Text -> IO (Int, Text)
getArrayDimsAndBase Server
srv (Field -> Text
fieldType Field
fld)
                let totalDimCount = Int
dimCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
innerDimCount
                    fArrTy = Int -> Text -> Text
T.replicate Int
totalDimCount Text
"[]" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
innerBaseTy
                automaticGenerator srv fVarName fArrTy size rng

              case sequence results of
                Just [Text]
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
                Maybe [Text]
Nothing -> do
                  Server -> [Text] -> IO ()
freeVars Server
srv [Text
candidate]
                  Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM (Text
"Failed to zip array of records " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Server -> Text -> Text -> [Text] -> IO (Maybe CmdFailure)
cmdZip Server
srv Text
candidate Text
genTy [Text]
fieldVarNames

                  Server -> [Text] -> IO ()
freeVars Server
srv [Text]
fieldVarNames
                  Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
            Left CmdFailure
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ CmdFailure -> Text
forall a. Show a => a -> Text
showText CmdFailure
err
        Kind
_ -> do
          let shapeList :: [Int64]
shapeList = Int -> Int64 -> [Int64]
forall a. Int -> a -> [a]
replicate Int
dimCount Int64
size
          seed <- PBTGen -> IO Word64
forall (m :: * -> *). MonadIO m => PBTGen -> m Word64
genWord64 PBTGen
rng
          case makeFutPrimitiveValue baseTy shapeList seed of
            Right Value
val -> do
              Server -> [Text] -> IO ()
freeVars Server
srv [Text
candidate]
              putRes <- Server -> Text -> Value -> IO (Maybe CmdFailure)
FSV.putValue Server
srv Text
candidate Value
val
              case putRes of
                Maybe CmdFailure
Nothing -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
                Just CmdFailure
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ CmdFailure -> Text
forall a. Show a => a -> Text
showText CmdFailure
err
            Left Text
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
err
    Kind
_ -> do
      seed <- PBTGen -> IO Word64
forall (m :: * -> *). MonadIO m => PBTGen -> m Word64
genWord64 PBTGen
rng
      case makeFutPrimitiveValue genTy [] seed of
        Right Value
val -> do
          Server -> [Text] -> IO ()
freeVars Server
srv [Text
candidate]
          putRes <- Server -> Text -> Value -> IO (Maybe CmdFailure)
FSV.putValue Server
srv Text
candidate Value
val
          case putRes of
            Maybe CmdFailure
Nothing -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
            Just CmdFailure
err -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ CmdFailure -> Text
forall a. Show a => a -> Text
showText CmdFailure
err
        Left Text
_ -> do
          let genName :: Text
genName = Text
"gen_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
genTy
              szVar :: Text
szVar = Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_$size"
              sdVar :: Text
sdVar = Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_$seed"

          Server -> Text -> Int64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
szVar Int64
size
          Server -> Text -> Word64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
sdVar Word64
seed

          Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callFreeIns Server
srv Text
genName Text
candidate [Text
szVar, Text
sdVar]

-- | Recursively unwrap arrays using the Futhark server to handle type aliases dynamically.
getArrayDimsAndBase :: Server -> TypeName -> IO (Int, TypeName)
getArrayDimsAndBase :: Server -> Text -> IO (Int, Text)
getArrayDimsAndBase Server
srv Text
t
  | Text
"[]" Text -> Text -> Bool
`T.isPrefixOf` Text
t = do
      (d, base) <- Server -> Text -> IO (Int, Text)
getArrayDimsAndBase Server
srv (Int -> Text -> Text
T.drop Int
2 Text
t)
      pure (d + 1, base)
  | Bool
otherwise = do
      kRes <- Server -> Text -> IO (Either CmdFailure Kind)
cmdKind Server
srv Text
t
      case kRes of
        Right Kind
Array -> do
          etRes <- Server -> Text -> IO (Either CmdFailure Text)
cmdElemtype Server
srv Text
t
          case etRes of
            Right Text
et -> do
              (d, base) <- Server -> Text -> IO (Int, Text)
getArrayDimsAndBase Server
srv Text
et
              pure (d + 1, base)
            Left CmdFailure
_ -> (Int, Text) -> IO (Int, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Text
t) -- Fallback if server fails to resolve elemtype
        Either CmdFailure Kind
_ -> (Int, Text) -> IO (Int, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Text
t)

makeFutPrimitiveValue :: TypeName -> [Int64] -> Word64 -> Either PBTFailure Value
makeFutPrimitiveValue :: Text -> [Int64] -> Word64 -> Either Text Value
makeFutPrimitiveValue Text
ty [Int64]
shape Word64
seed =
  case Text
ty of
    Text
"i8" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
I8) Word64
seed
    Text
"i16" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
I16) Word64
seed
    Text
"i32" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
I32) Word64
seed
    Text
"i64" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
I64) Word64
seed
    Text
"u8" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
U8) Word64
seed
    Text
"u16" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
U16) Word64
seed
    Text
"u32" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
U32) Word64
seed
    Text
"u64" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
U64) Word64
seed
    Text
"f16" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
F16) Word64
seed
    Text
"f32" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
F32) Word64
seed
    Text
"f64" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
F64) Word64
seed
    Text
"bool" -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ RandomConfiguration -> ValueType -> Word64 -> Value
randomValue RandomConfiguration
cfg ([Int] -> PrimType -> ValueType
ValueType [Int]
shape' PrimType
Bool) Word64
seed
    Text
_ -> Text -> Either Text Value
forall a b. a -> Either a b
Left (Text
"Automatic generation not implemented for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty)
  where
    shape' :: [Int]
shape' = (Int64 -> Int) -> [Int64] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int64]
shape
    cfg :: RandomConfiguration
cfg = RandomConfiguration
initialRandomConfiguration {f32Range = (-1, 1)}

runOne :: PropSpec -> PBTConfig -> Server -> IORef PBTPhase -> FilePath -> IO (Either PBTFailure PBTOutput)
runOne :: PropSpec
-> PBTConfig
-> Server
-> IORef PBTPhase
-> String
-> IO (Either Text (Maybe Text))
runOne PropSpec
s PBTConfig
config Server
srv IORef PBTPhase
entryNameRef String
program = ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text)))
-> ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$ do
  rng <- StdGen -> ExceptT Text IO PBTGen
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM (StdGen -> ExceptT Text IO PBTGen)
-> StdGen -> ExceptT Text IO PBTGen
forall a b. (a -> b) -> a -> b
$ Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ PBTConfig -> Word64
configSeed PBTConfig
config
  let loop Int32
i
        | Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
numTests = Maybe Text -> ExceptT Text m (Maybe Text)
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
        | Bool
otherwise = Int32 -> ExceptT Text m (Maybe Text)
check (Int32
i Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1)
      check Int32
i = do
        seed <- PBTGen -> ExceptT Text m Word64
forall (m :: * -> *). MonadIO m => PBTGen -> m Word64
genWord64 PBTGen
rng
        let runUpdate Text
ph =
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase
                  (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
propName)
                  (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ph)
                  Maybe Text
forall a. Maybe a
Nothing
                  (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
size)
                  Maybe Word64
forall a. Maybe a
Nothing
                  Maybe Word64
forall a. Maybe a
Nothing
                  IORef PBTPhase
entryNameRef

        generatorCandidateM <- liftIO $ generatorPhase seed
        maybe (pure ()) throwE generatorCandidateM

        runUpdate propName

        okE <-
          liftIO $ withCallKeepIns srv propName serverOk [serverIn] $ getVal srv
        ok <- case okE of
          Right Bool
b -> Bool -> ExceptT Text m Bool
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
          Left Text
err -> do
            IO () -> ExceptT Text m ()
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text m ()) -> IO () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$
              Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
"cmdStore failed to store when property crashed" (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$
                Server -> String -> [Text] -> IO (Maybe CmdFailure)
cmdStore Server
srv String
propertyFileName [Text
serverIn]
            valuePPrint <- IO Text -> ExceptT Text m Text
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
pPrintPhase
            throwE $
              "Property "
                <> propName
                <> " failed with candidate="
                <> valuePPrint
                <> " with error: "
                <> err
        if ok
          then loop i
          else do
            let failmsg =
                  Text
"Property "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propName
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (size="
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
showText Int64
size
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", seed="
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showText (PBTConfig -> Word64
configSeed PBTConfig
config)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") failed after "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int32 -> Text
forall a. Show a => a -> Text
showText Int32
i
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" tests:\n"

            shrinkRes <- case psShrink s of
              Maybe Text
Nothing ->
                IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text (Maybe Text))
 -> ExceptT Text m (Either Text (Maybe Text)))
-> IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$
                  Server
-> Text
-> Maybe Text
-> Text
-> Int64
-> Word64
-> Text
-> Text
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
autoShrinkLoop
                    Server
srv
                    Text
propName
                    Maybe Text
genName
                    Text
serverIn
                    Int64
size
                    Word64
seed
                    Text
serverSize
                    Text
serverSeed
                    IORef PBTPhase
entryNameRef
              Just Text
sh -> do
                userShrinkRes <-
                  IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text (Maybe Text))
 -> ExceptT Text m (Either Text (Maybe Text)))
-> IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$
                    Server
-> Text
-> Text
-> Text
-> PBTGen
-> Int
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
shrinkLoop
                      Server
srv
                      Text
propName
                      Text
serverIn
                      Text
sh
                      PBTGen
rng
                      (PBTConfig -> Int
configShrinkTries PBTConfig
config)
                      IORef PBTPhase
entryNameRef

                case userShrinkRes of
                  Right Maybe Text
Nothing ->
                    Either Text (Maybe Text)
-> ExceptT Text m (Either Text (Maybe Text))
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Either Text (Maybe Text)
forall a b. b -> Either a b
Right Maybe Text
forall a. Maybe a
Nothing)
                  Right (Just Text
err) -> do
                    autoRes <-
                      IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text (Maybe Text))
 -> ExceptT Text m (Either Text (Maybe Text)))
-> IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$
                        Server
-> Text
-> Maybe Text
-> Text
-> Int64
-> Word64
-> Text
-> Text
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
autoShrinkLoop
                          Server
srv
                          Text
propName
                          Maybe Text
genName
                          Text
serverIn
                          Int64
size
                          Word64
seed
                          Text
serverSize
                          Text
serverSeed
                          IORef PBTPhase
entryNameRef

                    pure $
                      Right $
                        Just $
                          "User shrinker failed: "
                            <> err
                            <> "\nAttempted auto-shrinker fallback."
                            <> formatAutoShrinkResult autoRes
                  Left Text
err -> do
                    autoRes <-
                      IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text (Maybe Text))
 -> ExceptT Text m (Either Text (Maybe Text)))
-> IO (Either Text (Maybe Text))
-> ExceptT Text m (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$
                        Server
-> Text
-> Maybe Text
-> Text
-> Int64
-> Word64
-> Text
-> Text
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
autoShrinkLoop
                          Server
srv
                          Text
propName
                          Maybe Text
genName
                          Text
serverIn
                          Int64
size
                          Word64
seed
                          Text
serverSize
                          Text
serverSeed
                          IORef PBTPhase
entryNameRef

                    pure $
                      Right $
                        Just $
                          "User shrinker failed: "
                            <> err
                            <> "\nAttempted auto-shrinker fallback."
                            <> formatAutoShrinkResult autoRes

            case shrinkRes of
              Left Text
err -> do
                Text -> ExceptT Text m ()
forall {m :: * -> *}. MonadIO m => Text -> m ()
runUpdate Text
"prettyPrint"
                counterLog <- IO Text -> ExceptT Text m Text
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
pPrintPhase
                liftIO $ cmdErrorHandlerM "cmdStore failed to store when shrinker crashed" $ cmdStore srv propertyFileName [serverIn]
                pure $
                  Just $
                    failmsg
                      <> "Shrinking failed: "
                      <> err
                      <> "\nCounterexample: "
                      <> counterLog
              Right (Just Text
note) -> do
                Text -> ExceptT Text m ()
forall {m :: * -> *}. MonadIO m => Text -> m ()
runUpdate Text
"prettyPrint"
                counterLog <- IO Text -> ExceptT Text m Text
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
pPrintPhase
                pure $
                  Just $
                    failmsg
                      <> "Shrinking note: "
                      <> note
                      <> "\nCounterexample: "
                      <> counterLog
              Right Maybe Text
Nothing -> do
                Text -> ExceptT Text m ()
forall {m :: * -> *}. MonadIO m => Text -> m ()
runUpdate Text
"prettyPrint"
                counterLog <- IO Text -> ExceptT Text m Text
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
pPrintPhase
                liftIO $
                  cmdErrorHandlerM "cmdStore failed to store shrinker result" $
                    cmdStore srv propertyFileName [serverIn]
                pure $ Just $ failmsg <> "Counterexample: " <> counterLog
  loop 0
  where
    propName :: Text
propName = PropSpec -> Text
psProp PropSpec
s
    genName :: Maybe Text
genName = PropSpec -> Maybe Text
psGen PropSpec
s
    size :: Int64
size = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (PBTConfig -> Int64
configMaxSize PBTConfig
config) (PropSpec -> Maybe Int64
psSize PropSpec
s)
    numTests :: Int32
numTests = PBTConfig -> Int32
configNumTests PBTConfig
config
    serverSize :: Text
serverSize = Text
"runPBT_size"
    serverSeed :: Text
serverSeed = Text
"runPBT_seed"
    serverIn :: Text
serverIn = Text
"runPBT_input"
    serverOk :: Text
serverOk = Text
"runPBT_ok"
    propertyFileName :: String
propertyFileName =
      ShowS
dropExtension String
program String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
propName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".counterexample"

    generatorPhase :: Word64 -> IO (Maybe Text)
generatorPhase Word64
seed = do
      let runUpdate :: Text -> m ()
runUpdate Text
ph =
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
              Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase
                (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
propName)
                (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ph)
                Maybe Text
forall a. Maybe a
Nothing
                (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
size)
                (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
seed)
                Maybe Word64
forall a. Maybe a
Nothing
                IORef PBTPhase
entryNameRef
      case Maybe Text
genName of
        Maybe Text
Nothing -> (Either Text () -> Maybe Text)
-> IO (Either Text ()) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (() -> Maybe Text) -> Either Text () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (IO (Either Text ()) -> IO (Maybe Text))
-> (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO ()
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Maybe Text))
-> ExceptT Text IO () -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
          IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO ()
freeVars Server
srv [Text
serverIn]
          propType <-
            IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> IO (Either Text Text)
getSingleInputType Server
srv Text
propName) ExceptT Text IO (Either Text Text)
-> (Either Text Text -> ExceptT Text IO Text)
-> ExceptT Text IO Text
forall a b.
ExceptT Text IO a -> (a -> ExceptT Text IO b) -> ExceptT Text IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left Text
err -> Text -> ExceptT Text IO Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO Text) -> Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
showText Text
err
              Right Text
ty -> Text -> ExceptT Text IO Text
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ty

          rng <- newIOGenM $ mkStdGen $ fromIntegral seed
          errM <- liftIO $ automaticGenerator srv serverIn propType size rng
          maybe (pure ()) (throwE . ("Automatic generator failed: " <>)) errM
        Just Text
gn -> (Either Text () -> Maybe Text)
-> IO (Either Text ()) -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (() -> Maybe Text) -> Either Text () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (IO (Either Text ()) -> IO (Maybe Text))
-> (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO ()
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Maybe Text))
-> ExceptT Text IO () -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
          Text -> ExceptT Text IO ()
forall {m :: * -> *}. MonadIO m => Text -> m ()
runUpdate Text
"User Generator"
          IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Int64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSize Int64
size
          IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Word64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSeed Word64
seed

          let genOut :: Text
genOut = Text -> Text
outName Text
gn

          IO (Either Text ()) -> ExceptT Text IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text ()) -> ExceptT Text IO ())
-> IO (Either Text ()) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Either Text ()) -> IO (Either Text ())
forall a. Server -> [Text] -> IO a -> IO a
withFreedVars Server
srv [Text
genOut] (IO (Either Text ()) -> IO (Either Text ()))
-> IO (Either Text ()) -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
            IO (Maybe Text) -> ExceptT Text IO (Maybe Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callFreeIns Server
srv Text
gn Text
genOut [Text
serverSize, Text
serverSeed]) ExceptT Text IO (Maybe Text)
-> (Maybe Text -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a b.
ExceptT Text IO a -> (a -> ExceptT Text IO b) -> ExceptT Text IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe Text
Nothing -> () -> ExceptT Text IO ()
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Just Text
err -> do
                IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Int64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSize Int64
size IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Server -> Text -> Word64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSeed Word64
seed
                IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
                  Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
"cmdStore failed to store generator error: " (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Server -> String -> [Text] -> IO (Maybe CmdFailure)
cmdStore Server
srv String
propertyFileName [Text
serverSize, Text
serverSeed]
                IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO ()
freeVars Server
srv [Text
serverSize, Text
serverSeed]
                Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
                  Text
"User Generator "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gn
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed with size="
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
showText Int64
size
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and seed="
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showText Word64
seed
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with error: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err

            IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO ()
renameVar Server
srv Text
serverIn Text
genOut

    pPrintPhase :: IO Text
pPrintPhase = do
      inputTypes <- Server -> Text -> IO [Text]
getInputTypes Server
srv Text
propName
      case inputTypes of
        [] -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Could not retrieve input type for counterexample."
        Text
ty0 : [Text]
_ -> Server -> Text -> Text -> IO Text
prettyVar Server
srv Text
serverIn Text
ty0

formatAutoShrinkResult :: Either PBTFailure PBTOutput -> T.Text
formatAutoShrinkResult :: Either Text (Maybe Text) -> Text
formatAutoShrinkResult Either Text (Maybe Text)
autoRes =
  case Either Text (Maybe Text)
autoRes of
    Right Maybe Text
Nothing ->
      Text
"\nAuto-shrinker fallback completed."
    Right (Just Text
msg) ->
      Text
"\nAuto-shrinker fallback completed with note: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
    Left Text
autoErr ->
      Text
"\nAuto-shrinker fallback also failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
autoErr

updatePhase ::
  Maybe EntryName ->
  Maybe EntryName ->
  Maybe EntryName ->
  Maybe Int64 ->
  Maybe Word64 ->
  Maybe Word64 ->
  IORef PBTPhase ->
  IO ()
updatePhase :: Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase Maybe Text
propName Maybe Text
phase Maybe Text
activeTest Maybe Int64
size Maybe Word64
seed Maybe Word64
rand IORef PBTPhase
phaseRef =
  IORef PBTPhase -> PBTPhase -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef PBTPhase
phaseRef (PBTPhase -> IO ()) -> PBTPhase -> IO ()
forall a b. (a -> b) -> a -> b
$
    PBTPhase
      { activeTest :: Maybe Text
activeTest = Maybe Text
propName,
        phase :: Maybe Text
phase = Maybe Text
phase,
        shrinkWith :: Maybe Text
shrinkWith = Maybe Text
activeTest,
        phaseSize :: Maybe Int64
phaseSize = Maybe Int64
size,
        phaseSeed :: Maybe Word64
phaseSeed = Maybe Word64
seed,
        phaseRandom :: Maybe Word64
phaseRandom = Maybe Word64
rand
      }

-- Given a known counterexample (generated with provided size and seed), here we
-- try to find a smaller counterexample by decreasing the size (but using the
-- same seed) until the generated value stops being a counterexample.
--
-- XXX: currently the automatic generator does not reuse the seed, but creates a
-- new PBTGen from it.
autoShrinkLoop ::
  Server ->
  EntryName ->
  Maybe EntryName ->
  VarName ->
  Int64 ->
  Word64 ->
  VarName ->
  VarName ->
  IORef PBTPhase ->
  IO (Either PBTFailure PBTOutput)
autoShrinkLoop :: Server
-> Text
-> Maybe Text
-> Text
-> Int64
-> Word64
-> Text
-> Text
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
autoShrinkLoop Server
srv Text
propName Maybe Text
genName Text
vCounterExample Int64
size Word64
seed Text
serverSize Text
serverSeed IORef PBTPhase
phaseRef = ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text)))
-> ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$ do
  let loop :: Int64 -> ExceptT Text m (Maybe a)
loop Int64
i
        | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
1 = Maybe a -> ExceptT Text m (Maybe a)
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            let newSize :: Int64
newSize = Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1

            errM <- IO (Maybe Text) -> ExceptT Text m (Maybe Text)
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ExceptT Text m (Maybe Text))
-> IO (Maybe Text) -> ExceptT Text m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Int64 -> IO (Maybe Text)
forall {f :: * -> *}. MonadIO f => Int64 -> f (Maybe Text)
generatorPhase Int64
newSize
            maybe (pure ()) (throwE . ("Auto-shrinker generator failed: " <>)) errM

            liftIO $ autoShrinkUpdatePhase (Right $ Just propName)

            ok <-
              either (throwE . ("Property " <>)) pure <=< liftIO $
                withCallKeepIns srv propName vOk [vCandidate] $
                  getVal srv

            liftIO $ autoShrinkUpdatePhase (Left Nothing)

            case ok of
              Bool
True -> do
                IO () -> ExceptT Text m ()
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text m ()) -> IO () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO ()
freeVars Server
srv [Text
vCandidate]
                Int64 -> ExceptT Text m (Maybe a)
loop Int64
newSize
              Bool
False -> do
                IO () -> ExceptT Text m ()
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text m ()) -> IO () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$
                  Server -> [Text] -> IO () -> IO ()
forall a. Server -> [Text] -> IO a -> IO a
freeOnException Server
srv [Text
vCounterExample] (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Server -> Text -> Text -> IO ()
renameVar Server
srv Text
vCounterExample Text
vCandidate
                Int64 -> ExceptT Text m (Maybe a)
loop Int64
newSize
  Int64 -> ExceptT Text IO (Maybe Text)
forall {m :: * -> *} {a}.
MonadIO m =>
Int64 -> ExceptT Text m (Maybe a)
loop Int64
size
  where
    vCandidate :: Text
vCandidate = Text
"auto_shrink_candidate"
    vOk :: Text
vOk = Text
"auto_shrink_ok"
    autoShrinkUpdatePhase :: Either a (Maybe Text) -> m ()
autoShrinkUpdatePhase Either a (Maybe Text)
active =
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase
          (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
propName)
          (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"autoShrinkLoop")
          (Maybe Text -> Either a (Maybe Text) -> Maybe Text
forall b a. b -> Either a b -> b
fromRight (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Automatic generator") Either a (Maybe Text)
active)
          (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
size)
          (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
seed)
          Maybe Word64
forall a. Maybe a
Nothing
          IORef PBTPhase
phaseRef
    generatorPhase :: Int64 -> f (Maybe Text)
generatorPhase Int64
size' = do
      (Either Text (Either Text ()) -> Maybe Text)
-> f (Either Text (Either Text ())) -> f (Maybe Text)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe Text)
-> (Either Text () -> Maybe Text)
-> Either Text (Either Text ())
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> Either Text () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)) (f (Either Text (Either Text ())) -> f (Maybe Text))
-> (ExceptT Text f (Either Text ())
    -> f (Either Text (Either Text ())))
-> ExceptT Text f (Either Text ())
-> f (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text f (Either Text ()) -> f (Either Text (Either Text ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text f (Either Text ()) -> f (Maybe Text))
-> ExceptT Text f (Either Text ()) -> f (Maybe Text)
forall a b. (a -> b) -> a -> b
$
        case Maybe Text
genName of
          Maybe Text
Nothing -> do
            propertyType <- do
              IO (Either Text Text) -> ExceptT Text f (Either Text Text)
forall a. IO a -> ExceptT Text f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> IO (Either Text Text)
getSingleInputType Server
srv Text
propName) ExceptT Text f (Either Text Text)
-> (Either Text Text -> ExceptT Text f Text) -> ExceptT Text f Text
forall a b.
ExceptT Text f a -> (a -> ExceptT Text f b) -> ExceptT Text f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left Text
err -> Text -> ExceptT Text f Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text f Text) -> Text -> ExceptT Text f Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. Show a => a -> Text
showText Text
err
                Right Text
ty -> Text -> ExceptT Text f Text
forall a. a -> ExceptT Text f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ty
            liftIO $ freeVars srv [serverSize, serverSeed]
            runExceptT $ do
              rng <- newIOGenM $ mkStdGen $ fromIntegral seed
              errM <- liftIO $ automaticGenerator srv vCandidate propertyType size' rng
              maybe (pure ()) (throwE . ("Automatic generator failed: " <>)) errM
          Just Text
gn -> do
            IO () -> ExceptT Text f ()
forall a. IO a -> ExceptT Text f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text f ()) -> IO () -> ExceptT Text f ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Int64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSize Int64
size' IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Server -> Text -> Word64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
serverSeed Word64
seed
            ExceptT Text (ExceptT Text f) () -> ExceptT Text f (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (ExceptT Text f) ()
 -> ExceptT Text f (Either Text ()))
-> ExceptT Text (ExceptT Text f) ()
-> ExceptT Text f (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
              errM <- IO (Maybe Text) -> ExceptT Text (ExceptT Text f) (Maybe Text)
forall a. IO a -> ExceptT Text (ExceptT Text f) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ExceptT Text (ExceptT Text f) (Maybe Text))
-> IO (Maybe Text) -> ExceptT Text (ExceptT Text f) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callFreeIns Server
srv Text
gn Text
vCandidate [Text
serverSize, Text
serverSeed]
              maybe (pure ()) (\Text
err -> Text -> ExceptT Text (ExceptT Text f) ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text (ExceptT Text f) ())
-> Text -> ExceptT Text (ExceptT Text f) ()
forall a b. (a -> b) -> a -> b
$ Text
"User Generator " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err) errM

data Step
  = -- | Property still failed with the new candidate
    AcceptedShrink
  | -- | Property passed with the new candidate
    NotAcceptedShrink
  | -- | Shrinker error (including property failure in shrinker)
    ErrorInShrink T.Text
  deriving (Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
/= :: Step -> Step -> Bool
Eq, Int -> Step -> ShowS
[Step] -> ShowS
Step -> String
(Int -> Step -> ShowS)
-> (Step -> String) -> ([Step] -> ShowS) -> Show Step
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Step -> ShowS
showsPrec :: Int -> Step -> ShowS
$cshow :: Step -> String
show :: Step -> String
$cshowList :: [Step] -> ShowS
showList :: [Step] -> ShowS
Show)

shrinkLoop :: Server -> EntryName -> VarName -> EntryName -> PBTGen -> Int -> IORef PBTPhase -> IO (Either PBTFailure PBTOutput)
shrinkLoop :: Server
-> Text
-> Text
-> Text
-> PBTGen
-> Int
-> IORef PBTPhase
-> IO (Either Text (Maybe Text))
shrinkLoop Server
srv Text
propName Text
counterExample Text
shrinkName PBTGen
rng Int
numTries IORef PBTPhase
phaseRef = ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text)))
-> ExceptT Text IO (Maybe Text) -> IO (Either Text (Maybe Text))
forall a b. (a -> b) -> a -> b
$ do
  -- 1. Setup Phase
  oldRef <- IO PBTPhase -> ExceptT Text IO PBTPhase
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PBTPhase -> ExceptT Text IO PBTPhase)
-> IO PBTPhase -> ExceptT Text IO PBTPhase
forall a b. (a -> b) -> a -> b
$ IORef PBTPhase -> IO PBTPhase
forall a. IORef a -> IO a
readIORef IORef PBTPhase
phaseRef
  let size = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
0 (PBTPhase -> Maybe Int64
phaseSize PBTPhase
oldRef)
      shrinkUpdatePhase Maybe Text
activeTest =
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
          Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase
            (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
propName)
            (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
shrinkName)
            Maybe Text
activeTest
            (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
size)
            Maybe Word64
forall a. Maybe a
Nothing
            Maybe Word64
forall a. Maybe a
Nothing
            IORef PBTPhase
phaseRef

  shrinkUpdatePhase Nothing

  let loop (Int
acc :: Int) (Int
totalCounter :: Int)
        | Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numTries = Maybe a -> ExceptT Text m (Maybe a)
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            random_value <- PBTGen -> ExceptT Text m Word64
forall (m :: * -> *). MonadIO m => PBTGen -> m Word64
genWord64 PBTGen
rng
            stepResultE <- liftIO $ oneStep size random_value
            stepResult <-
              either
                ( \Text
err ->
                    Text -> ExceptT Text m Step
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text m Step) -> Text -> ExceptT Text m Step
forall a b. (a -> b) -> a -> b
$
                      Text
"Error in shrinker "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shrinkName
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with random="
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showText Word64
random_value
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                )
                pure
                stepResultE

            case stepResult of
              Step
AcceptedShrink ->
                Int -> Int -> ExceptT Text m (Maybe a)
loop Int
0 (Int
totalCounter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -- Reset trials on success
              Step
NotAcceptedShrink ->
                Int -> Int -> ExceptT Text m (Maybe a)
loop (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
totalCounter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -- Increment trials
              ErrorInShrink Text
err ->
                Text -> ExceptT Text m (Maybe a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text m (Maybe a))
-> Text -> ExceptT Text m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text
"Error in shrinker: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
  loop 0 0
  where
    oneStep :: Int64 -> Word64 -> IO (Either Text Step)
oneStep Int64
size (Word64
val :: Word64) = do
      let vCandidate :: Text
vCandidate = Text
"shrink_candidate"
          vOk :: Text
vOk = Text
"shrink_ok"
          vRandomValue :: Text
vRandomValue = Text
"shrink_random"

      let shrinkUpdatePhase :: Maybe Text -> Maybe Word64 -> IO ()
shrinkUpdatePhase Maybe Text
activeTest Maybe Word64
randomNum =
            Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Int64
-> Maybe Word64
-> Maybe Word64
-> IORef PBTPhase
-> IO ()
updatePhase
              (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
propName)
              (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
shrinkName)
              Maybe Text
activeTest
              (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
size)
              Maybe Word64
forall a. Maybe a
Nothing
              Maybe Word64
randomNum
              IORef PBTPhase
phaseRef

      Server -> [Text] -> IO ()
freeVars Server
srv [Text
vRandomValue]
      Server -> Text -> Word64 -> IO ()
forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
srv Text
vRandomValue Word64
val

      Maybe Text -> Maybe Word64 -> IO ()
shrinkUpdatePhase Maybe Text
forall a. Maybe a
Nothing (Maybe Word64 -> IO ()) -> Maybe Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
val

      Server -> Text -> IO (Either Text Step) -> IO (Either Text Step)
forall a. Server -> Text -> IO a -> IO a
withFreedVar Server
srv Text
vCandidate (IO (Either Text Step) -> IO (Either Text Step))
-> IO (Either Text Step) -> IO (Either Text Step)
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO Step -> IO (Either Text Step)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Step -> IO (Either Text Step))
-> ExceptT Text IO Step -> IO (Either Text Step)
forall a b. (a -> b) -> a -> b
$ do
        errE <- IO (Maybe Text) -> ExceptT Text IO (Maybe Text)
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ExceptT Text IO (Maybe Text))
-> IO (Maybe Text) -> ExceptT Text IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callKeepIns Server
srv Text
shrinkName Text
vCandidate [Text
counterExample, Text
vRandomValue]
        liftIO $ freeVars srv [vRandomValue]
        maybe (pure ()) (throwE . ((shrinkName <> " has ") <>)) errE

        liftIO $ shrinkUpdatePhase Nothing $ Just $ fromIntegral val

        ok <-
          either (throwE . ("Property " <>)) pure <=< liftIO $
            withCallKeepIns srv propName vOk [vCandidate] $
              getVal srv

        liftIO $ shrinkUpdatePhase Nothing $ Just $ fromIntegral val

        case ok of
          Bool
True -> Step -> ExceptT Text IO Step
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
NotAcceptedShrink
          Bool
False -> do
            IO () -> ExceptT Text IO ()
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO ()
renameVar Server
srv Text
counterExample Text
vCandidate
            Step -> ExceptT Text IO Step
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
AcceptedShrink

-- | Name of out-variable for this entry point.
outName :: EntryName -> VarName
outName :: Text -> Text
outName = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out")

putVal :: (PutValue1 a) => Server -> T.Text -> a -> IO ()
putVal :: forall a. PutValue1 a => Server -> Text -> a -> IO ()
putVal Server
s Text
name a
x = do
  let v :: Value
v = a -> Value
forall t. PutValue1 t => t -> Value
putValue1 a
x
  Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM (Text
"putValue failed for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Value -> IO (Maybe CmdFailure)
FSV.putValue Server
s Text
name Value
v

freeVars :: Server -> [VarName] -> IO ()
freeVars :: Server -> [Text] -> IO ()
freeVars Server
s [Text]
vs = do
  mFail <- Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
s [Text]
vs
  case mFail of
    Maybe CmdFailure
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just CmdFailure
err
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
T.isPrefixOf Text
"Unknown variable:") (CmdFailure -> [Text]
failureMsg CmdFailure
err) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise ->
          Text -> IO ()
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text
"cmdFree failed for "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showText [Text]
vs
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showText (CmdFailure -> [Text]
failureMsg CmdFailure
err)

callFreeIns :: Server -> EntryName -> VarName -> [VarName] -> IO (Maybe PBTFailure)
callFreeIns :: Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callFreeIns Server
s Text
entry Text
out [Text]
ins = do
  Server -> [Text] -> IO ()
freeVars Server
s [Text
out]
  r <- Server -> Text -> Text -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
s Text
entry Text
out [Text]
ins
  freeVars s ins
  either (pure . handleRuntimeError entry) (const $ pure Nothing) r

isRuntimeError :: CmdFailure -> Bool
isRuntimeError :: CmdFailure -> Bool
isRuntimeError CmdFailure
failure = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
"runtime: " Text -> Text -> Bool
`T.isPrefixOf`) (CmdFailure -> [Text]
failureLog CmdFailure
failure)

handleRuntimeError :: EntryName -> CmdFailure -> Maybe PBTFailure
handleRuntimeError :: Text -> CmdFailure -> Maybe Text
handleRuntimeError Text
entry CmdFailure
err
  | CmdFailure -> Bool
isRuntimeError CmdFailure
err = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Runtime error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showText (CmdFailure -> [Text]
failureMsg CmdFailure
err)
  | Bool
otherwise =
      Text -> Maybe Text
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
        Text
"Fatal Error on "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showText (CmdFailure -> [Text]
failureMsg CmdFailure
err)

callKeepIns :: Server -> EntryName -> VarName -> [VarName] -> IO (Maybe PBTFailure)
callKeepIns :: Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callKeepIns Server
s Text
entry Text
out [Text]
ins = do
  Server -> [Text] -> IO ()
freeVars Server
s [Text
out]
  r <- Server -> Text -> Text -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
s Text
entry Text
out [Text]
ins
  either (pure . handleRuntimeError entry) (const $ pure Nothing) r

freeOnException :: Server -> [VarName] -> IO a -> IO a
freeOnException :: forall a. Server -> [Text] -> IO a -> IO a
freeOnException Server
srv [Text]
vs IO a
action =
  IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` Server -> [Text] -> IO ()
freeVars Server
srv [Text]
vs

withCallKeepIns :: Server -> EntryName -> VarName -> [VarName] -> (VarName -> IO a) -> IO (Either PBTFailure a)
withCallKeepIns :: forall a.
Server
-> Text -> Text -> [Text] -> (Text -> IO a) -> IO (Either Text a)
withCallKeepIns Server
srv Text
entry Text
out [Text]
ins Text -> IO a
k = do
  errM <- Server -> Text -> Text -> [Text] -> IO (Maybe Text)
callKeepIns Server
srv Text
entry Text
out [Text]
ins
  maybe
    (Right <$> (k out `finally` freeVars srv [out]))
    (pure . Left . ((entry <> " has ") <>))
    errM

withFreedVars :: Server -> [VarName] -> IO a -> IO a
withFreedVars :: forall a. Server -> [Text] -> IO a -> IO a
withFreedVars Server
srv [Text]
vs IO a
action =
  IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Server -> [Text] -> IO ()
freeVars Server
srv [Text]
vs

-- | Bracket a single temporary var name.
withFreedVar :: Server -> VarName -> IO a -> IO a
withFreedVar :: forall a. Server -> Text -> IO a -> IO a
withFreedVar Server
srv Text
v = Server -> [Text] -> IO a -> IO a
forall a. Server -> [Text] -> IO a -> IO a
withFreedVars Server
srv [Text
v]

renameVar :: Server -> VarName -> VarName -> IO ()
renameVar :: Server -> Text -> Text -> IO ()
renameVar Server
srv Text
new Text
old = do
  Server -> [Text] -> IO ()
freeVars Server
srv [Text
new]
  Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
"cmdRename failed: " (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO (Maybe CmdFailure)
cmdRename Server
srv Text
old Text
new

cmdErrorHandlerM :: T.Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM :: Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
msg IO (Maybe CmdFailure)
action = IO (Maybe CmdFailure)
action IO (Maybe CmdFailure) -> (Maybe CmdFailure -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (CmdFailure -> IO ()) -> Maybe CmdFailure -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Text -> IO ()
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> IO ()) -> (CmdFailure -> Text) -> CmdFailure -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> Text
forall a. Show a => a -> Text
format)
  where
    format :: a -> Text
format a
err = Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showText a
err

cmdErrorHandlerE :: T.Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE :: forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
msg IO (Either CmdFailure a)
action = IO (Either CmdFailure a)
action IO (Either CmdFailure a) -> (Either CmdFailure a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CmdFailure -> IO a) -> (a -> IO a) -> Either CmdFailure a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> IO a
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> IO a) -> (CmdFailure -> Text) -> CmdFailure -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> Text
forall a. Show a => a -> Text
format) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    format :: a -> Text
format a
err = Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showText a
err

getVal :: (GetValue a) => Server -> VarName -> IO a
getVal :: forall a. GetValue a => Server -> Text -> IO a
getVal Server
srv Text
name = do
  v <- Server -> Text -> IO Value
getDataVal Server
srv Text
name
  case getValue v of
    Just a
b -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
    Maybe a
Nothing ->
      Text -> IO a
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$
        Text
"Expected "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to decode, got: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
valueText Value
v

getDataVal :: Server -> VarName -> IO Value
getDataVal :: Server -> Text -> IO Value
getDataVal Server
s Text
name = do
  r <- Server -> Text -> IO (Either Text Value)
FSV.getValue Server
s Text
name
  case r of
    Left Text
msg ->
      Text -> IO Value
forall (m :: * -> *) a. MonadFail m => Text -> m a
unexpectedFailure (Text -> IO Value) -> Text -> IO Value
forall a b. (a -> b) -> a -> b
$
        Text
"getValue failed for "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
    Right Value
v -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

prettyVar :: Server -> VarName -> TypeName -> IO T.Text
prettyVar :: Server -> Text -> Text -> IO Text
prettyVar Server
srv Text
v Text
ty = do
  kRes <- Text -> IO (Either CmdFailure Kind) -> IO Kind
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
"cmdKind failed: " (IO (Either CmdFailure Kind) -> IO Kind)
-> IO (Either CmdFailure Kind) -> IO Kind
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure Kind)
cmdKind Server
srv Text
ty
  case kRes of
    Kind
Record -> do
      fieldsRes <- Server -> Text -> IO (Either CmdFailure [Field])
cmdFields Server
srv Text
ty
      case fieldsRes of
        Right [Field]
fieldLines -> do
          let fnames :: [Text]
fnames = (Field -> Text) -> [Field] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
fieldName [Field]
fieldLines
              ftypes :: [Text]
ftypes = (Field -> Text) -> [Field] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
fieldType [Field]
fieldLines
              isTuple :: Bool
isTuple = ((Text, Int) -> Bool) -> [(Text, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Text
n, Int
i :: Int) -> Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Text
forall a. Show a => a -> Text
showText Int
i) ([Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fnames [Int
0 ..])

          rendered <- [(Text, Text)] -> ((Text, Text) -> IO Text) -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fnames [Text]
ftypes) (((Text, Text) -> IO Text) -> IO [Text])
-> ((Text, Text) -> IO Text) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ \(Text
fname, Text
fty) -> do
            let tmp :: Text
tmp = Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_proj_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname
            sField <- Server -> Text -> IO Text -> IO Text
forall a. Server -> Text -> IO a -> IO a
withFreedVar Server
srv Text
tmp (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
              Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
"project failed: " (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> Text -> IO (Maybe CmdFailure)
cmdProject Server
srv Text
tmp Text
v Text
fname
              Server -> Text -> Text -> IO Text
prettyVar Server
srv Text
tmp Text
fty
            pure $ if isTuple then sField else fname <> " = " <> sField

          pure $
            if isTuple
              then "(" <> T.intercalate ", " rendered <> ")"
              else "{" <> T.intercalate ", " rendered <> "}"
        Left CmdFailure
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<error: record fields missing>"
    Kind
Array -> do
      valRes <- Server -> Text -> IO (Either Text Value)
FSV.getValue Server
srv Text
v
      case valRes of
        Right Value
val -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Text
valueText Value
val)
        Left Text
_ -> do
          dims <- Text -> IO (Either CmdFailure [Int]) -> IO [Int]
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
"cmdShape failed: " (IO (Either CmdFailure [Int]) -> IO [Int])
-> IO (Either CmdFailure [Int]) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [Int])
cmdShape Server
srv Text
v
          baseTy <- getBaseType ty
          buildNested v baseTy dims []
    Kind
_ -> IO Text
fallbackValue
  where
    fallbackValue :: IO Text
fallbackValue = do
      valRes <- Server -> Text -> IO (Either Text Value)
FSV.getValue Server
srv Text
v
      case valRes of
        Right Value
val -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Text
valueText Value
val)
        Left Text
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"<opaque:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">")

    getBaseType :: TypeName -> IO TypeName
    getBaseType :: Text -> IO Text
getBaseType Text
t = do
      k <- Text -> IO (Either CmdFailure Kind) -> IO Kind
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
"cmdKind failed: " (IO (Either CmdFailure Kind) -> IO Kind)
-> IO (Either CmdFailure Kind) -> IO Kind
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure Kind)
cmdKind Server
srv Text
t
      case k of
        Kind
Array -> do
          et <- Text -> IO (Either CmdFailure Text) -> IO Text
forall a. Text -> IO (Either CmdFailure a) -> IO a
cmdErrorHandlerE Text
"cmdElemtype failed: " (IO (Either CmdFailure Text) -> IO Text)
-> IO (Either CmdFailure Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure Text)
cmdElemtype Server
srv Text
t
          getBaseType et
        Kind
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t

    buildNested :: VarName -> TypeName -> [Int] -> [Int] -> IO T.Text
    buildNested :: Text -> Text -> [Int] -> [Int] -> IO Text
buildNested Text
varName Text
baseType [Int]
dims [Int]
currentPath =
      case [Int]
dims of
        [] -> do
          let pathStr :: Text
pathStr = Text -> [Text] -> Text
T.intercalate Text
"_" ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
showText [Int]
currentPath)
              tmpElem :: Text
tmpElem = Text
varName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_elem_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathStr

          Server -> Text -> IO Text -> IO Text
forall a. Server -> Text -> IO a -> IO a
withFreedVar Server
srv Text
tmpElem (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
            Text -> IO (Maybe CmdFailure) -> IO ()
cmdErrorHandlerM Text
"index failed: " (IO (Maybe CmdFailure) -> IO ()) -> IO (Maybe CmdFailure) -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> [Int] -> IO (Maybe CmdFailure)
cmdIndex Server
srv Text
tmpElem Text
varName [Int]
currentPath
            Server -> Text -> Text -> IO Text
prettyVar Server
srv Text
tmpElem Text
baseType
        (Int
d : [Int]
restDims) -> do
          elements <- [Int] -> (Int -> IO Text) -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO Text) -> IO [Text]) -> (Int -> IO Text) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ \Int
idx -> do
            Text -> Text -> [Int] -> [Int] -> IO Text
buildNested Text
varName Text
baseType [Int]
restDims ([Int]
currentPath [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
idx])

          pure $ "[" <> T.intercalate ", " elements <> "]"

getSingleInputType :: Server -> EntryName -> IO (Either PBTFailure TypeName)
getSingleInputType :: Server -> Text -> IO (Either Text Text)
getSingleInputType Server
srv Text
ep = do
  tys <- Server -> Text -> IO [Text]
getInputTypes Server
srv Text
ep
  case tys of
    [Text
ty] -> Either Text Text -> IO (Either Text Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right Text
ty
    [] -> Either Text Text -> IO (Either Text Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Entrypoint " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ep String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has no inputs (expected 1)."
    [Text]
_ -> Either Text Text -> IO (Either Text Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Entrypoint " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ep String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has >1 input (expected 1): " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
tys

-- | Run a list of property specifications, returning a list of results.
-- Each result is either a failure with an error message or a success.
runPBT :: PBTConfig -> Server -> [PropSpec] -> IORef PBTPhase -> FilePath -> IO [Either PBTFailure PBTOutput]
runPBT :: PBTConfig
-> Server
-> [PropSpec]
-> IORef PBTPhase
-> String
-> IO [Either Text (Maybe Text)]
runPBT PBTConfig
config Server
srv [PropSpec]
specs IORef PBTPhase
entryNameRef String
program =
  [PropSpec]
-> (PropSpec -> IO (Either Text (Maybe Text)))
-> IO [Either Text (Maybe Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PropSpec]
specs ((PropSpec -> IO (Either Text (Maybe Text)))
 -> IO [Either Text (Maybe Text)])
-> (PropSpec -> IO (Either Text (Maybe Text)))
-> IO [Either Text (Maybe Text)]
forall a b. (a -> b) -> a -> b
$ \PropSpec
spec ->
    PropSpec
-> PBTConfig
-> Server
-> IORef PBTPhase
-> String
-> IO (Either Text (Maybe Text))
runOne PropSpec
spec PBTConfig
config Server
srv IORef PBTPhase
entryNameRef String
program