{-# LANGUAGE CPP #-}
#if MIN_VERSION_random(1,3,0)
{-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split`
#endif
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Generate example CBOR given a CDDL specification
module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where

#if MIN_VERSION_random(1,3,0)
import System.Random.Stateful (
  SplitGen (..)
  )
#endif
import Capability.Reader
import Capability.Sink (HasSink)
import Capability.Source (HasSource, MonadState (..))
import Capability.State (HasState, get, modify)
import Codec.CBOR.Cuddle.CDDL (
  Name (..),
  OccurrenceIndicator (..),
  Value (..),
  ValueVariant (..),
 )
import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator (..), WrappedTerm (..))
import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), PTerm (..), foldCTree)
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
import Codec.CBOR.Term (Term (..))
import Codec.CBOR.Term qualified as CBOR
import Codec.CBOR.Write qualified as CBOR
import Control.Monad (join, replicateM, (<=<))
import Control.Monad.Reader (Reader, runReader)
import Control.Monad.State.Strict (StateT, runStateT)
import Control.Monad.State.Strict qualified as MTL
import Data.Bifunctor (second)
import Data.ByteString (ByteString)
import Data.Functor ((<&>))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word32)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import System.Random.Stateful (
  Random,
  RandomGen (..),
  StateGenM (..),
  UniformRange (uniformRM),
  randomM,
  uniformByteStringM,
 )

type data MonoDropGen

newtype instance XXCTree MonoDropGen = MDGRef Name
  deriving (Int -> Node MonoDropGen -> ShowS
[Node MonoDropGen] -> ShowS
Node MonoDropGen -> String
(Int -> Node MonoDropGen -> ShowS)
-> (Node MonoDropGen -> String)
-> ([Node MonoDropGen] -> ShowS)
-> Show (Node MonoDropGen)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node MonoDropGen -> ShowS
showsPrec :: Int -> Node MonoDropGen -> ShowS
$cshow :: Node MonoDropGen -> String
show :: Node MonoDropGen -> String
$cshowList :: [Node MonoDropGen] -> ShowS
showList :: [Node MonoDropGen] -> ShowS
Show)

instance IndexMappable CTree MonoReferenced MonoDropGen where
  mapIndex :: CTree MonoReferenced -> CTree MonoDropGen
mapIndex = (XXCTree MonoReferenced -> CTree MonoDropGen)
-> (CTree MonoReferenced -> CTree MonoDropGen)
-> CTree MonoReferenced
-> CTree MonoDropGen
forall i j.
(XXCTree i -> CTree j)
-> (CTree i -> CTree j) -> CTree i -> CTree j
foldCTree XXCTree MonoReferenced -> CTree MonoDropGen
mapExt CTree MonoReferenced -> CTree MonoDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex
    where
      mapExt :: XXCTree MonoReferenced -> CTree MonoDropGen
mapExt (MRuleRef Name
n) = Node MonoDropGen -> CTree MonoDropGen
forall i. XXCTree i -> CTree i
CTreeE (Node MonoDropGen -> CTree MonoDropGen)
-> Node MonoDropGen -> CTree MonoDropGen
forall a b. (a -> b) -> a -> b
$ Name -> Node MonoDropGen
MDGRef Name
n
      mapExt (MGenerator CBORGenerator
_ CTree MonoReferenced
x) = CTree MonoReferenced -> CTree MonoDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTree MonoReferenced
x

--------------------------------------------------------------------------------
-- Generator infrastructure
--------------------------------------------------------------------------------

-- | Generator context, parametrised over the type of the random seed
newtype GenEnv = GenEnv
  { GenEnv -> CTreeRoot MonoReferenced
cddl :: CTreeRoot MonoReferenced
  }
  deriving ((forall x. GenEnv -> Rep GenEnv x)
-> (forall x. Rep GenEnv x -> GenEnv) -> Generic GenEnv
forall x. Rep GenEnv x -> GenEnv
forall x. GenEnv -> Rep GenEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GenEnv -> Rep GenEnv x
from :: forall x. GenEnv -> Rep GenEnv x
$cto :: forall x. Rep GenEnv x -> GenEnv
to :: forall x. Rep GenEnv x -> GenEnv
Generic)

data GenState g = GenState
  { forall g. GenState g -> g
randomSeed :: g
  -- ^ Actual seed
  , forall g. GenState g -> Int
depth :: Int
  -- ^ Depth of the generator. This measures the number of references we
  -- follow. As we go deeper into the tree, we try to reduce the likelihood of
  -- following recursive paths, and generate shorter lists where allowed by
  -- the occurrence bounds.
  }
  deriving ((forall x. GenState g -> Rep (GenState g) x)
-> (forall x. Rep (GenState g) x -> GenState g)
-> Generic (GenState g)
forall x. Rep (GenState g) x -> GenState g
forall x. GenState g -> Rep (GenState g) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall g x. Rep (GenState g) x -> GenState g
forall g x. GenState g -> Rep (GenState g) x
$cfrom :: forall g x. GenState g -> Rep (GenState g) x
from :: forall x. GenState g -> Rep (GenState g) x
$cto :: forall g x. Rep (GenState g) x -> GenState g
to :: forall x. Rep (GenState g) x -> GenState g
Generic)

instance RandomGen g => RandomGen (GenState g) where
  genWord8 :: GenState g -> (Word8, GenState g)
genWord8 = (g -> (Word8, g)) -> GenState g -> (Word8, GenState g)
forall t a g. (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed g -> (Word8, g)
forall g. RandomGen g => g -> (Word8, g)
genWord8
  genWord16 :: GenState g -> (Word16, GenState g)
genWord16 = (g -> (Word16, g)) -> GenState g -> (Word16, GenState g)
forall t a g. (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed g -> (Word16, g)
forall g. RandomGen g => g -> (Word16, g)
genWord16
  genWord32 :: GenState g -> (Word32, GenState g)
genWord32 = (g -> (Word32, g)) -> GenState g -> (Word32, GenState g)
forall t a g. (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed g -> (Word32, g)
forall g. RandomGen g => g -> (Word32, g)
genWord32
  genWord64 :: GenState g -> (Word64, GenState g)
genWord64 = (g -> (Word64, g)) -> GenState g -> (Word64, GenState g)
forall t a g. (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed g -> (Word64, g)
forall g. RandomGen g => g -> (Word64, g)
genWord64
  split :: GenState g -> (GenState g, GenState g)
split = (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
forall g. (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
splitGenStateWith g -> (g, g)
forall g. RandomGen g => g -> (g, g)
split

#if MIN_VERSION_random(1,3,0)
instance SplitGen g => SplitGen (GenState g) where
  splitGen :: GenState g -> (GenState g, GenState g)
splitGen = (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
forall g. (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
splitGenStateWith g -> (g, g)
forall g. SplitGen g => g -> (g, g)
splitGen
#endif

splitGenStateWith :: (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
splitGenStateWith :: forall g. (g -> (g, g)) -> GenState g -> (GenState g, GenState g)
splitGenStateWith g -> (g, g)
f GenState g
s =
  case g -> (g, g)
f (GenState g -> g
forall g. GenState g -> g
randomSeed GenState g
s) of
    (g
gen', g
gen) -> (GenState g
s {randomSeed = gen'}, GenState g
s {randomSeed = gen})

withRandomSeed :: (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed :: forall t a g. (t -> (a, g)) -> GenState t -> (a, GenState g)
withRandomSeed t -> (a, g)
f GenState t
s =
  case t -> (a, g)
f (GenState t -> t
forall g. GenState g -> g
randomSeed GenState t
s) of
    (a
r, g
gen) -> (a
r, GenState t
s {randomSeed = gen})

newtype M g a = M {forall g a. M g a -> StateT (GenState g) (Reader GenEnv) a
runM :: StateT (GenState g) (Reader GenEnv) a}
  deriving ((forall a b. (a -> b) -> M g a -> M g b)
-> (forall a b. a -> M g b -> M g a) -> Functor (M g)
forall a b. a -> M g b -> M g a
forall a b. (a -> b) -> M g a -> M g b
forall g a b. a -> M g b -> M g a
forall g a b. (a -> b) -> M g a -> M g b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall g a b. (a -> b) -> M g a -> M g b
fmap :: forall a b. (a -> b) -> M g a -> M g b
$c<$ :: forall g a b. a -> M g b -> M g a
<$ :: forall a b. a -> M g b -> M g a
Functor, Functor (M g)
Functor (M g) =>
(forall a. a -> M g a)
-> (forall a b. M g (a -> b) -> M g a -> M g b)
-> (forall a b c. (a -> b -> c) -> M g a -> M g b -> M g c)
-> (forall a b. M g a -> M g b -> M g b)
-> (forall a b. M g a -> M g b -> M g a)
-> Applicative (M g)
forall g. Functor (M g)
forall a. a -> M g a
forall g a. a -> M g a
forall a b. M g a -> M g b -> M g a
forall a b. M g a -> M g b -> M g b
forall a b. M g (a -> b) -> M g a -> M g b
forall g a b. M g a -> M g b -> M g a
forall g a b. M g a -> M g b -> M g b
forall g a b. M g (a -> b) -> M g a -> M g b
forall a b c. (a -> b -> c) -> M g a -> M g b -> M g c
forall g a b c. (a -> b -> c) -> M g a -> M g b -> M g c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall g a. a -> M g a
pure :: forall a. a -> M g a
$c<*> :: forall g a b. M g (a -> b) -> M g a -> M g b
<*> :: forall a b. M g (a -> b) -> M g a -> M g b
$cliftA2 :: forall g a b c. (a -> b -> c) -> M g a -> M g b -> M g c
liftA2 :: forall a b c. (a -> b -> c) -> M g a -> M g b -> M g c
$c*> :: forall g a b. M g a -> M g b -> M g b
*> :: forall a b. M g a -> M g b -> M g b
$c<* :: forall g a b. M g a -> M g b -> M g a
<* :: forall a b. M g a -> M g b -> M g a
Applicative, Applicative (M g)
Applicative (M g) =>
(forall a b. M g a -> (a -> M g b) -> M g b)
-> (forall a b. M g a -> M g b -> M g b)
-> (forall a. a -> M g a)
-> Monad (M g)
forall g. Applicative (M g)
forall a. a -> M g a
forall g a. a -> M g a
forall a b. M g a -> M g b -> M g b
forall a b. M g a -> (a -> M g b) -> M g b
forall g a b. M g a -> M g b -> M g b
forall g a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall g a b. M g a -> (a -> M g b) -> M g b
>>= :: forall a b. M g a -> (a -> M g b) -> M g b
$c>> :: forall g a b. M g a -> M g b -> M g b
>> :: forall a b. M g a -> M g b -> M g b
$creturn :: forall g a. a -> M g a
return :: forall a. a -> M g a
Monad, MTL.MonadState (GenState g))
  deriving
    (HasSource "randomSeed" g, HasSink "randomSeed" g, HasState "randomSeed" g)
    via Field
          "randomSeed"
          ()
          (MonadState (StateT (GenState g) (Reader GenEnv)))
  deriving
    (HasSource "depth" Int, HasSink "depth" Int, HasState "depth" Int)
    via Field
          "depth"
          ()
          (MonadState (StateT (GenState g) (Reader GenEnv)))
  deriving
    ( HasSource "cddl" (CTreeRoot MonoReferenced)
    , HasReader "cddl" (CTreeRoot MonoReferenced)
    )
    via Field
          "cddl"
          ()
          (Lift (StateT (GenState g) (MonadReader (Reader GenEnv))))

runGen :: M g a -> GenEnv -> GenState g -> (a, GenState g)
runGen :: forall g a. M g a -> GenEnv -> GenState g -> (a, GenState g)
runGen M g a
m GenEnv
env GenState g
st = Reader GenEnv (a, GenState g) -> GenEnv -> (a, GenState g)
forall r a. Reader r a -> r -> a
runReader (StateT (GenState g) (Reader GenEnv) a
-> GenState g -> Reader GenEnv (a, GenState g)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (M g a -> StateT (GenState g) (Reader GenEnv) a
forall g a. M g a -> StateT (GenState g) (Reader GenEnv) a
runM M g a
m) GenState g
st) GenEnv
env

evalGen :: M g a -> GenEnv -> GenState g -> a
evalGen :: forall g a. M g a -> GenEnv -> GenState g -> a
evalGen M g a
m GenEnv
env = (a, GenState g) -> a
forall a b. (a, b) -> a
fst ((a, GenState g) -> a)
-> (GenState g -> (a, GenState g)) -> GenState g -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M g a -> GenEnv -> GenState g -> (a, GenState g)
forall g a. M g a -> GenEnv -> GenState g -> (a, GenState g)
runGen M g a
m GenEnv
env

--------------------------------------------------------------------------------
-- Wrappers around some Random function in Gen
--------------------------------------------------------------------------------

genUniformRM :: forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM :: forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (a, a)
r = (a, a) -> StateGenM (GenState g) -> M g a
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (a, a) -> g -> m a
uniformRM (a, a)
r (forall g. StateGenM g
StateGenM @(GenState g))

-- | Generate a random number in a given range, biased increasingly towards the
-- lower end as the depth parameter increases.
genDepthBiasedRM ::
  forall a g.
  (Ord a, UniformRange a, RandomGen g) =>
  (a, a) ->
  M g a
genDepthBiasedRM :: forall a g. (Ord a, UniformRange a, RandomGen g) => (a, a) -> M g a
genDepthBiasedRM (a, a)
bounds = do
  Int
d <- forall {k} (tag :: k) s (m :: * -> *). HasState tag s m => m s
forall (tag :: Symbol) s (m :: * -> *). HasState tag s m => m s
get @"depth"
  [a]
samples <- Int -> M g a -> M g [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
d ((a, a) -> M g a
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (a, a)
bounds)
  a -> M g a
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> M g a) -> a -> M g a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
samples

-- | Generates a bool, increasingly likely to be 'False' as the depth increases.
genDepthBiasedBool :: forall g. RandomGen g => M g Bool
genDepthBiasedBool :: forall g. RandomGen g => M g Bool
genDepthBiasedBool = do
  Int
d <- forall {k} (tag :: k) s (m :: * -> *). HasState tag s m => m s
forall (tag :: Symbol) s (m :: * -> *). HasState tag s m => m s
get @"depth"
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> M g [Bool] -> M g Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g Bool -> M g [Bool]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
d M g Bool
forall g a. (Random a, RandomGen g) => M g a
genRandomM

genRandomM :: forall g a. (Random a, RandomGen g) => M g a
genRandomM :: forall g a. (Random a, RandomGen g) => M g a
genRandomM = MutableGen (StateGen (GenState g)) (M g) -> M g a
forall a g (m :: * -> *).
(Random a, RandomGen g, FrozenGen g m) =>
MutableGen g m -> m a
randomM (forall g. StateGenM g
StateGenM @(GenState g))

genBytes :: forall g. RandomGen g => Int -> M g ByteString
genBytes :: forall g. RandomGen g => Int -> M g ByteString
genBytes Int
n = Int -> StateGenM (GenState g) -> M g ByteString
forall g (m :: * -> *). StatefulGen g m => Int -> g -> m ByteString
uniformByteStringM Int
n (forall g. StateGenM g
StateGenM @(GenState g))

genText :: forall g. RandomGen g => Int -> M g Text
genText :: forall g. RandomGen g => Int -> M g Text
genText Int
n = Text -> M g Text
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> M g Text) -> Text -> M g Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. a -> [a]
repeat [Char
'a' .. Char
'z']

--------------------------------------------------------------------------------
-- Postlude
--------------------------------------------------------------------------------

-- | Primitive types defined by the CDDL specification, with their generators
genPostlude :: RandomGen g => PTerm -> M g Term
genPostlude :: forall g. RandomGen g => PTerm -> M g Term
genPostlude PTerm
pt = case PTerm
pt of
  PTerm
PTBool ->
    M g Bool
forall g a. (Random a, RandomGen g) => M g a
genRandomM
      M g Bool -> (Bool -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Term
TBool
  PTerm
PTUInt ->
    (Word32, Word32) -> M g Word32
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Word32
forall a. Bounded a => a
minBound :: Word32, Word32
forall a. Bounded a => a
maxBound)
      M g Word32 -> (Word32 -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Integer -> Term
TInteger
        (Integer -> Term) -> (Word32 -> Integer) -> Word32 -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  PTerm
PTNInt ->
    (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM
      (Int
forall a. Bounded a => a
minBound :: Int, Int
0)
      M g Int -> (Int -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Integer -> Term
TInteger
        (Integer -> Term) -> (Int -> Integer) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  PTerm
PTInt ->
    (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
forall a. Bounded a => a
minBound :: Int, Int
forall a. Bounded a => a
maxBound)
      M g Int -> (Int -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Integer -> Term
TInteger
        (Integer -> Term) -> (Int -> Integer) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  PTerm
PTHalf ->
    (Float, Float) -> M g Float
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (-Float
65504, Float
65504)
      M g Float -> (Float -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Float -> Term
THalf
  PTerm
PTFloat ->
    M g Float
forall g a. (Random a, RandomGen g) => M g a
genRandomM
      M g Float -> (Float -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Float -> Term
TFloat
  PTerm
PTDouble ->
    M g Double
forall g a. (Random a, RandomGen g) => M g a
genRandomM
      M g Double -> (Double -> Term) -> M g Term
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Double -> Term
TDouble
  PTerm
PTBytes -> ByteString -> Term
TBytes (ByteString -> Term) -> M g ByteString -> M g Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g ByteString
forall g. RandomGen g => Int -> M g ByteString
genBytes Int
30
  PTerm
PTText -> Text -> Term
TString (Text -> Term) -> M g Text -> M g Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g Text
forall g. RandomGen g => Int -> M g Text
genText Int
30
  PTerm
PTAny -> Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ Text -> Term
TString Text
"Any"
  PTerm
PTNil -> Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
TNull
  PTerm
PTUndefined -> Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ Word8 -> Term
TSimple Word8
23

--------------------------------------------------------------------------------
-- Kinds of terms
--------------------------------------------------------------------------------

-- | Recursively flatten wrapped list. That is, expand any groups out to their
-- individual entries.
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
flattenWrappedList [] = []
flattenWrappedList (G [WrappedTerm]
xxs : [WrappedTerm]
xs) =
  [WrappedTerm] -> [WrappedTerm]
flattenWrappedList [WrappedTerm]
xxs [WrappedTerm] -> [WrappedTerm] -> [WrappedTerm]
forall a. Semigroup a => a -> a -> a
<> [WrappedTerm] -> [WrappedTerm]
flattenWrappedList [WrappedTerm]
xs
flattenWrappedList (WrappedTerm
y : [WrappedTerm]
xs) = WrappedTerm
y WrappedTerm -> [WrappedTerm] -> [WrappedTerm]
forall a. a -> [a] -> [a]
: [WrappedTerm] -> [WrappedTerm]
flattenWrappedList [WrappedTerm]
xs

-- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are
-- present, we just take their "value" part.
singleTermList :: [WrappedTerm] -> Maybe [Term]
singleTermList :: [WrappedTerm] -> Maybe [Term]
singleTermList [] = [Term] -> Maybe [Term]
forall a. a -> Maybe a
Just []
singleTermList (S Term
x : [WrappedTerm]
xs) = (Term
x :) ([Term] -> [Term]) -> Maybe [Term] -> Maybe [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WrappedTerm] -> Maybe [Term]
singleTermList [WrappedTerm]
xs
singleTermList (P Term
_ Term
y : [WrappedTerm]
xs) = (Term
y :) ([Term] -> [Term]) -> Maybe [Term] -> Maybe [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WrappedTerm] -> Maybe [Term]
singleTermList [WrappedTerm]
xs
singleTermList [WrappedTerm]
_ = Maybe [Term]
forall a. Maybe a
Nothing

-- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any
-- 'SingleTerm's are present.
pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
pairTermList [] = [(Term, Term)] -> Maybe [(Term, Term)]
forall a. a -> Maybe a
Just []
pairTermList (P Term
x Term
y : [WrappedTerm]
xs) = ((Term
x, Term
y) :) ([(Term, Term)] -> [(Term, Term)])
-> Maybe [(Term, Term)] -> Maybe [(Term, Term)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WrappedTerm] -> Maybe [(Term, Term)]
pairTermList [WrappedTerm]
xs
pairTermList [WrappedTerm]
_ = Maybe [(Term, Term)]
forall a. Maybe a
Nothing

showDropGen :: CTree MonoReferenced -> String
showDropGen :: CTree MonoReferenced -> String
showDropGen = CTree MonoDropGen -> String
forall a. Show a => a -> String
show (CTree MonoDropGen -> String)
-> (CTree MonoReferenced -> CTree MonoDropGen)
-> CTree MonoReferenced
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
forall (f :: * -> *) i j. IndexMappable f i j => f i -> f j
mapIndex @_ @_ @MonoDropGen

--------------------------------------------------------------------------------
-- Generator functions
--------------------------------------------------------------------------------

genForCTree :: (HasCallStack, RandomGen g) => CTree MonoReferenced -> M g WrappedTerm
genForCTree :: forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree (CTree.Literal Value
v) = Term -> WrappedTerm
S (Term -> WrappedTerm) -> M g Term -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> M g Term
forall g. RandomGen g => Value -> M g Term
genValue Value
v
genForCTree (CTree.Postlude PTerm
pt) = Term -> WrappedTerm
S (Term -> WrappedTerm) -> M g Term -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PTerm -> M g Term
forall g. RandomGen g => PTerm -> M g Term
genPostlude PTerm
pt
genForCTree (CTree.Map [CTree MonoReferenced]
nodes) = do
  Maybe [(Term, Term)]
items <- [WrappedTerm] -> Maybe [(Term, Term)]
pairTermList ([WrappedTerm] -> Maybe [(Term, Term)])
-> ([WrappedTerm] -> [WrappedTerm])
-> [WrappedTerm]
-> Maybe [(Term, Term)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WrappedTerm] -> [WrappedTerm]
flattenWrappedList ([WrappedTerm] -> Maybe [(Term, Term)])
-> M g [WrappedTerm] -> M g (Maybe [(Term, Term)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CTree MonoReferenced -> M g WrappedTerm)
-> [CTree MonoReferenced] -> M g [WrappedTerm]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree [CTree MonoReferenced]
nodes
  case Maybe [(Term, Term)]
items of
    Just [(Term, Term)]
ts ->
      let
        -- De-duplicate keys in the map.
        -- Per RFC7049:
        -- >> A map that has duplicate keys may be well-formed, but it is not
        -- >> valid, and thus it causes indeterminate decoding
        tsNodup :: [(Term, Term)]
tsNodup = Map Term Term -> [(Term, Term)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Term Term -> [(Term, Term)])
-> Map Term Term -> [(Term, Term)]
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Map Term Term
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Term, Term)]
ts
       in
        WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm)
-> (Term -> WrappedTerm) -> Term -> M g WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> WrappedTerm
S (Term -> M g WrappedTerm) -> Term -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Term
TMap [(Term, Term)]
tsNodup
    Maybe [(Term, Term)]
Nothing -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Single terms in map context"
genForCTree (CTree.Array [CTree MonoReferenced]
nodes) = do
  Maybe [Term]
items <- [WrappedTerm] -> Maybe [Term]
singleTermList ([WrappedTerm] -> Maybe [Term])
-> ([WrappedTerm] -> [WrappedTerm])
-> [WrappedTerm]
-> Maybe [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WrappedTerm] -> [WrappedTerm]
flattenWrappedList ([WrappedTerm] -> Maybe [Term])
-> M g [WrappedTerm] -> M g (Maybe [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CTree MonoReferenced -> M g WrappedTerm)
-> [CTree MonoReferenced] -> M g [WrappedTerm]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree [CTree MonoReferenced]
nodes
  case Maybe [Term]
items of
    Just [Term]
ts -> WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm)
-> (Term -> WrappedTerm) -> Term -> M g WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> WrappedTerm
S (Term -> M g WrappedTerm) -> Term -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TList [Term]
ts
    Maybe [Term]
Nothing -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Something weird happened which shouldn't be possible"
genForCTree (CTree.Choice (NonEmpty (CTree MonoReferenced) -> [CTree MonoReferenced]
forall a. NonEmpty a -> [a]
NE.toList -> [CTree MonoReferenced]
nodes)) = do
  Int
ix <- (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
0, [CTree MonoReferenced] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTree MonoReferenced]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree (CTree MonoReferenced -> M g WrappedTerm)
-> CTree MonoReferenced -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [CTree MonoReferenced]
nodes [CTree MonoReferenced] -> Int -> CTree MonoReferenced
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
genForCTree (CTree.Group [CTree MonoReferenced]
nodes) = [WrappedTerm] -> WrappedTerm
G ([WrappedTerm] -> WrappedTerm)
-> M g [WrappedTerm] -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CTree MonoReferenced -> M g WrappedTerm)
-> [CTree MonoReferenced] -> M g [WrappedTerm]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree [CTree MonoReferenced]
nodes
genForCTree (CTree.KV CTree MonoReferenced
key CTree MonoReferenced
value Bool
_cut) = do
  WrappedTerm
kg <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
key
  WrappedTerm
vg <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
value
  case (WrappedTerm
kg, WrappedTerm
vg) of
    (S Term
k, S Term
v) -> WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm) -> WrappedTerm -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ Term -> Term -> WrappedTerm
P Term
k Term
v
    (WrappedTerm, WrappedTerm)
_ ->
      String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$
        String
"Non single-term generated outside of group context: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
key
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" => "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
value
genForCTree (CTree.Occur CTree MonoReferenced
item OccurrenceIndicator
occurs) =
  OccurrenceIndicator -> M g WrappedTerm -> M g WrappedTerm
forall g.
RandomGen g =>
OccurrenceIndicator -> M g WrappedTerm -> M g WrappedTerm
applyOccurenceIndicator OccurrenceIndicator
occurs (CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
item)
genForCTree (CTree.Range CTree MonoReferenced
from CTree MonoReferenced
to RangeBound
_bounds) = do
  -- TODO Handle bounds correctly
  WrappedTerm
term1 <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
from
  WrappedTerm
term2 <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
to
  case (WrappedTerm
term1, WrappedTerm
term2) of
    (S (TInt Int
a), S (TInt Int
b))
      | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
b -> (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
a, Int
b) M g Int -> (Int -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Int -> Term) -> Int -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt
    (S (TInt Int
a), S (TInteger Integer
b))
      | Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
b -> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a, Integer
b) M g Integer -> (Integer -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger
    (S (TInteger Integer
a), S (TInteger Integer
b))
      | Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
b -> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Integer
a, Integer
b) M g Integer -> (Integer -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger
    (S (THalf Float
a), S (THalf Float
b))
      | Float
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
b -> (Float, Float) -> M g Float
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Float
a, Float
b) M g Float -> (Float -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Float -> Term) -> Float -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Term
THalf
    (S (TFloat Float
a), S (TFloat Float
b))
      | Float
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
b -> (Float, Float) -> M g Float
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Float
a, Float
b) M g Float -> (Float -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Float -> Term) -> Float -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Term
TFloat
    (S (TDouble Double
a), S (TDouble Double
b))
      | Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
b -> (Double, Double) -> M g Double
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Double
a, Double
b) M g Double -> (Double -> WrappedTerm) -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Double -> Term) -> Double -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Term
TDouble
    (WrappedTerm
a, WrappedTerm
b) -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ String
"invalid range (a = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WrappedTerm -> String
forall a. Show a => a -> String
show WrappedTerm
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", b = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WrappedTerm -> String
forall a. Show a => a -> String
show WrappedTerm
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
genForCTree (CTree.Control CtlOp
op CTree MonoReferenced
target CTree MonoReferenced
controller) = do
  CTree MonoReferenced
resolvedController <- case CTree MonoReferenced
controller of
    CTreeE (MRuleRef Name
n) -> Name -> M g (CTree MonoReferenced)
forall g. RandomGen g => Name -> M g (CTree MonoReferenced)
resolveRef Name
n
    CTree MonoReferenced
x -> CTree MonoReferenced -> M g (CTree MonoReferenced)
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CTree MonoReferenced
x
  case (CtlOp
op, CTree MonoReferenced
resolvedController) of
    (CtlOp
CtlOp.Le, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoReferenced
target of
      CTree.Postlude PTerm
PTUInt -> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger (Integer -> WrappedTerm) -> M g Integer -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Integer
0, Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
      CTree MonoReferenced
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply le operator to target"
    (CtlOp
CtlOp.Le, CTree MonoReferenced
_) -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ String
"Invalid controller for .le operator: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
controller
    (CtlOp
CtlOp.Lt, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoReferenced
target of
      CTree.Postlude PTerm
PTUInt -> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger (Integer -> WrappedTerm) -> M g Integer -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Integer
0, Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      CTree MonoReferenced
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply lt operator to target"
    (CtlOp
CtlOp.Lt, CTree MonoReferenced
_) -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ String
"Invalid controller for .lt operator: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
controller
    (CtlOp
CtlOp.Size, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoReferenced
target of
      CTree.Postlude PTerm
PTText -> Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Text -> Term) -> Text -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term
TString (Text -> WrappedTerm) -> M g Text -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g Text
forall g. RandomGen g => Int -> M g Text
genText (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
      CTree.Postlude PTerm
PTBytes -> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (ByteString -> Term) -> ByteString -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Term
TBytes (ByteString -> WrappedTerm) -> M g ByteString -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g ByteString
forall g. RandomGen g => Int -> M g ByteString
genBytes (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
      CTree.Postlude PTerm
PTUInt -> Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger (Integer -> WrappedTerm) -> M g Integer -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Integer
0, Integer
2 Integer -> Word64 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Word64
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      CTree MonoReferenced
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply size operator to target "
    (CtlOp
CtlOp.Size, CTree.Range {CTree MonoReferenced
from :: CTree MonoReferenced
from :: forall i. CTree i -> CTree i
CTree.from, CTree MonoReferenced
to :: CTree MonoReferenced
to :: forall i. CTree i -> CTree i
CTree.to}) -> do
      case (CTree MonoReferenced
from, CTree MonoReferenced
to) of
        (CTree.Literal (Value (VUInt Word64
f1) Comment
_), CTree.Literal (Value (VUInt Word64
t1) Comment
_)) -> case CTree MonoReferenced
target of
          CTree.Postlude PTerm
PTText ->
            (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f1, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t1)
              M g Int -> (Int -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Text -> WrappedTerm) -> M g Text -> M g WrappedTerm
forall a b. (a -> b) -> M g a -> M g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term -> WrappedTerm
S (Term -> WrappedTerm) -> (Text -> Term) -> Text -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term
TString) (M g Text -> M g WrappedTerm)
-> (Int -> M g Text) -> Int -> M g WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> M g Text
forall g. RandomGen g => Int -> M g Text
genText)
          CTree.Postlude PTerm
PTBytes ->
            (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f1, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t1)
              M g Int -> (Int -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ByteString -> WrappedTerm) -> M g ByteString -> M g WrappedTerm
forall a b. (a -> b) -> M g a -> M g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (ByteString -> Term) -> ByteString -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Term
TBytes) (M g ByteString -> M g WrappedTerm)
-> (Int -> M g ByteString) -> Int -> M g WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> M g ByteString
forall g. RandomGen g => Int -> M g ByteString
genBytes)
          CTree.Postlude PTerm
PTUInt ->
            Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Integer -> Term) -> Integer -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Term
TInteger
              (Integer -> WrappedTerm) -> M g Integer -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> M g Integer
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
f1, Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t1)
          CTree MonoReferenced
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply size operator to target: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
target
        (CTree MonoReferenced, CTree MonoReferenced)
_ ->
          String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$
            String
"Invalid controller for .size operator: "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
controller
    (CtlOp
CtlOp.Size, CTree MonoReferenced
_) ->
      String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error (String -> M g WrappedTerm) -> String -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$
        String
"Invalid controller for .size operator: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoReferenced -> String
showDropGen CTree MonoReferenced
controller
    (CtlOp
CtlOp.Cbor, CTree MonoReferenced
_) -> do
      WrappedTerm
enc <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
controller
      case WrappedTerm
enc of
        S Term
x -> WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm)
-> (Encoding -> WrappedTerm) -> Encoding -> M g WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> WrappedTerm
S (Term -> WrappedTerm)
-> (Encoding -> Term) -> Encoding -> WrappedTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Term
TBytes (ByteString -> Term)
-> (Encoding -> ByteString) -> Encoding -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
CBOR.toStrictByteString (Encoding -> M g WrappedTerm) -> Encoding -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ Term -> Encoding
CBOR.encodeTerm Term
x
        WrappedTerm
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Controller does not correspond to a single term"
    (CtlOp, CTree MonoReferenced)
_ -> CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
target
genForCTree (CTree.Enum CTree MonoReferenced
tree) = do
  case CTree MonoReferenced
tree of
    CTree.Group [CTree MonoReferenced]
trees -> do
      Int
ix <- (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
0, [CTree MonoReferenced] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTree MonoReferenced]
trees Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree (CTree MonoReferenced -> M g WrappedTerm)
-> CTree MonoReferenced -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [CTree MonoReferenced]
trees [CTree MonoReferenced] -> Int -> CTree MonoReferenced
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
    CTree MonoReferenced
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Attempt to form an enum from something other than a group"
genForCTree (CTree.Unwrap CTree MonoReferenced
node) = CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
node
genForCTree (CTree.Tag Word64
tag CTree MonoReferenced
node) = do
  WrappedTerm
enc <- CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
node
  case WrappedTerm
enc of
    S Term
x -> WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm) -> WrappedTerm -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ Term -> WrappedTerm
S (Term -> WrappedTerm) -> Term -> WrappedTerm
forall a b. (a -> b) -> a -> b
$ Word64 -> Term -> Term
TTagged Word64
tag Term
x
    WrappedTerm
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Tag controller does not correspond to a single term"
genForCTree (CTree.CTreeE (MRuleRef Name
n)) = Name -> M g WrappedTerm
forall g. (HasCallStack, RandomGen g) => Name -> M g WrappedTerm
genForNode Name
n
genForCTree (CTree.CTreeE (MGenerator (CBORGenerator forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm
gen) CTree MonoReferenced
_)) = StateGenM (GenState g) -> M g WrappedTerm
forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm
gen StateGenM (GenState g)
forall g. StateGenM g
StateGenM

genForNode :: (HasCallStack, RandomGen g) => Name -> M g WrappedTerm
genForNode :: forall g. (HasCallStack, RandomGen g) => Name -> M g WrappedTerm
genForNode = CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree (CTree MonoReferenced -> M g WrappedTerm)
-> (Name -> M g (CTree MonoReferenced)) -> Name -> M g WrappedTerm
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> M g (CTree MonoReferenced)
forall g. RandomGen g => Name -> M g (CTree MonoReferenced)
resolveRef

-- | Take a reference and resolve it to the relevant Tree, following multiple
-- links if necessary.
resolveRef :: RandomGen g => Name -> M g (CTree MonoReferenced)
resolveRef :: forall g. RandomGen g => Name -> M g (CTree MonoReferenced)
resolveRef Name
n = do
  (CTreeRoot Map Name (CTree MonoReferenced)
cddl) <- forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall (tag :: Symbol) r (m :: * -> *). HasReader tag r m => m r
ask @"cddl"
  -- Since we follow a reference, we increase the 'depth' of the gen monad.
  forall {k} (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
forall (tag :: Symbol) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
modify @"depth" (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  case Name
-> Map Name (CTree MonoReferenced) -> Maybe (CTree MonoReferenced)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (CTree MonoReferenced)
cddl of
    Maybe (CTree MonoReferenced)
Nothing -> String -> M g (CTree MonoReferenced)
forall a. HasCallStack => String -> a
error (String -> M g (CTree MonoReferenced))
-> String -> M g (CTree MonoReferenced)
forall a b. (a -> b) -> a -> b
$ String
"Unbound reference: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
    Just CTree MonoReferenced
val -> CTree MonoReferenced -> M g (CTree MonoReferenced)
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CTree MonoReferenced
val

-- | Generate a CBOR Term corresponding to a top-level name.
--
-- Since we apply this to a monomorphised CTree, the names must be monomorphic
-- terms in the original CDDL.
--
-- This will throw an error if the generated item does not correspond to a
-- single CBOR term (e.g. if the name resolves to a group, which cannot be
-- generated outside a context).
genForName :: (HasCallStack, RandomGen g) => Name -> M g Term
genForName :: forall g. (HasCallStack, RandomGen g) => Name -> M g Term
genForName Name
n = do
  (CTreeRoot Map Name (CTree MonoReferenced)
cddl) <- forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall (tag :: Symbol) r (m :: * -> *). HasReader tag r m => m r
ask @"cddl"
  case Name
-> Map Name (CTree MonoReferenced) -> Maybe (CTree MonoReferenced)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (CTree MonoReferenced)
cddl of
    Maybe (CTree MonoReferenced)
Nothing -> String -> M g Term
forall a. HasCallStack => String -> a
error (String -> M g Term) -> String -> M g Term
forall a b. (a -> b) -> a -> b
$ String
"Unbound reference: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
    Just CTree MonoReferenced
val ->
      CTree MonoReferenced -> M g WrappedTerm
forall g.
(HasCallStack, RandomGen g) =>
CTree MonoReferenced -> M g WrappedTerm
genForCTree CTree MonoReferenced
val M g WrappedTerm -> (WrappedTerm -> M g Term) -> M g Term
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        S Term
x -> Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
x
        WrappedTerm
_ ->
          String -> M g Term
forall a. HasCallStack => String -> a
error (String -> M g Term) -> String -> M g Term
forall a b. (a -> b) -> a -> b
$
            String
"Tried to generate a top-level term for "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", but it does not correspond to a single term."

-- | Apply an occurence indicator to a group entry
applyOccurenceIndicator ::
  RandomGen g =>
  OccurrenceIndicator ->
  M g WrappedTerm ->
  M g WrappedTerm
applyOccurenceIndicator :: forall g.
RandomGen g =>
OccurrenceIndicator -> M g WrappedTerm -> M g WrappedTerm
applyOccurenceIndicator OccurrenceIndicator
OIOptional M g WrappedTerm
oldGen =
  M g Bool
forall g. RandomGen g => M g Bool
genDepthBiasedBool M g Bool -> (Bool -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> WrappedTerm -> M g WrappedTerm
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrappedTerm -> M g WrappedTerm) -> WrappedTerm -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [WrappedTerm] -> WrappedTerm
G [WrappedTerm]
forall a. Monoid a => a
mempty
    Bool
True -> M g WrappedTerm
oldGen
applyOccurenceIndicator OccurrenceIndicator
OIZeroOrMore M g WrappedTerm
oldGen =
  (Int, Int) -> M g Int
forall a g. (Ord a, UniformRange a, RandomGen g) => (a, a) -> M g a
genDepthBiasedRM (Int
0 :: Int, Int
10) M g Int -> (Int -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i ->
    [WrappedTerm] -> WrappedTerm
G ([WrappedTerm] -> WrappedTerm)
-> M g [WrappedTerm] -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g WrappedTerm -> M g [WrappedTerm]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i M g WrappedTerm
oldGen
applyOccurenceIndicator OccurrenceIndicator
OIOneOrMore M g WrappedTerm
oldGen =
  (Int, Int) -> M g Int
forall a g. (Ord a, UniformRange a, RandomGen g) => (a, a) -> M g a
genDepthBiasedRM (Int
1 :: Int, Int
10) M g Int -> (Int -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i ->
    [WrappedTerm] -> WrappedTerm
G ([WrappedTerm] -> WrappedTerm)
-> M g [WrappedTerm] -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g WrappedTerm -> M g [WrappedTerm]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i M g WrappedTerm
oldGen
applyOccurenceIndicator (OIBounded Maybe Word64
mlb Maybe Word64
mub) M g WrappedTerm
oldGen =
  (Word64, Word64) -> M g Word64
forall a g. (Ord a, UniformRange a, RandomGen g) => (a, a) -> M g a
genDepthBiasedRM (Word64
lo, Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe (Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
10 Word64
lo) Maybe Word64
mub)
    M g Word64 -> (Word64 -> M g WrappedTerm) -> M g WrappedTerm
forall a b. M g a -> (a -> M g b) -> M g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word64
i -> [WrappedTerm] -> WrappedTerm
G ([WrappedTerm] -> WrappedTerm)
-> M g [WrappedTerm] -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> M g WrappedTerm -> M g [WrappedTerm]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) M g WrappedTerm
oldGen
  where
    lo :: Word64
lo = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 Maybe Word64
mlb

genValue :: RandomGen g => Value -> M g Term
genValue :: forall g. RandomGen g => Value -> M g Term
genValue (Value ValueVariant
x Comment
_) = ValueVariant -> M g Term
forall g. RandomGen g => ValueVariant -> M g Term
genValueVariant ValueVariant
x

genValueVariant :: RandomGen g => ValueVariant -> M g Term
genValueVariant :: forall g. RandomGen g => ValueVariant -> M g Term
genValueVariant (VUInt Word64
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> (Int -> Term) -> Int -> M g Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt (Int -> M g Term) -> Int -> M g Term
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i
genValueVariant (VNInt Word64
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> (Int -> Term) -> Int -> M g Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
TInt (Int -> M g Term) -> Int -> M g Term
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Word64
i)
genValueVariant (VBignum Integer
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ Integer -> Term
TInteger Integer
i
genValueVariant (VFloat16 Float
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> (Float -> Term) -> Float -> M g Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Term
THalf (Float -> M g Term) -> Float -> M g Term
forall a b. (a -> b) -> a -> b
$ Float
i
genValueVariant (VFloat32 Float
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> (Float -> Term) -> Float -> M g Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Term
TFloat (Float -> M g Term) -> Float -> M g Term
forall a b. (a -> b) -> a -> b
$ Float
i
genValueVariant (VFloat64 Double
i) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> (Double -> Term) -> Double -> M g Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Term
TDouble (Double -> M g Term) -> Double -> M g Term
forall a b. (a -> b) -> a -> b
$ Double
i
genValueVariant (VText Text
t) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ Text -> Term
TString Text
t
genValueVariant (VBytes ByteString
b) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ ByteString -> Term
TBytes ByteString
b
genValueVariant (VBool Bool
b) = Term -> M g Term
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> M g Term) -> Term -> M g Term
forall a b. (a -> b) -> a -> b
$ Bool -> Term
TBool Bool
b

--------------------------------------------------------------------------------
-- Generator functions
--------------------------------------------------------------------------------

generateCBORTerm :: (HasCallStack, RandomGen g) => CTreeRoot MonoReferenced -> Name -> g -> Term
generateCBORTerm :: forall g.
(HasCallStack, RandomGen g) =>
CTreeRoot MonoReferenced -> Name -> g -> Term
generateCBORTerm CTreeRoot MonoReferenced
cddl Name
n g
stdGen =
  let genEnv :: GenEnv
genEnv = GenEnv {CTreeRoot MonoReferenced
cddl :: CTreeRoot MonoReferenced
cddl :: CTreeRoot MonoReferenced
cddl}
      genState :: GenState g
genState = GenState {randomSeed :: g
randomSeed = g
stdGen, depth :: Int
depth = Int
1}
   in M g Term -> GenEnv -> GenState g -> Term
forall g a. M g a -> GenEnv -> GenState g -> a
evalGen (Name -> M g Term
forall g. (HasCallStack, RandomGen g) => Name -> M g Term
genForName Name
n) GenEnv
genEnv GenState g
genState

generateCBORTerm' ::
  (HasCallStack, RandomGen g) => CTreeRoot MonoReferenced -> Name -> g -> (Term, g)
generateCBORTerm' :: forall g.
(HasCallStack, RandomGen g) =>
CTreeRoot MonoReferenced -> Name -> g -> (Term, g)
generateCBORTerm' CTreeRoot MonoReferenced
cddl Name
n g
stdGen =
  let genEnv :: GenEnv
genEnv = GenEnv {CTreeRoot MonoReferenced
cddl :: CTreeRoot MonoReferenced
cddl :: CTreeRoot MonoReferenced
cddl}
      genState :: GenState g
genState = GenState {randomSeed :: g
randomSeed = g
stdGen, depth :: Int
depth = Int
1}
   in (GenState g -> g) -> (Term, GenState g) -> (Term, g)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second GenState g -> g
forall g. GenState g -> g
randomSeed ((Term, GenState g) -> (Term, g))
-> (Term, GenState g) -> (Term, g)
forall a b. (a -> b) -> a -> b
$ M g Term -> GenEnv -> GenState g -> (Term, GenState g)
forall g a. M g a -> GenEnv -> GenState g -> (a, GenState g)
runGen (Name -> M g Term
forall g. (HasCallStack, RandomGen g) => Name -> M g Term
genForName Name
n) GenEnv
genEnv GenState g
genState