{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

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

import Capability.Reader
import Capability.Sink (HasSink)
import Capability.Source (HasSource, MonadState (..))
import Capability.State (HasState, get, modify, state)
import Codec.CBOR.Cuddle.CDDL (
  Name (..),
  OccurrenceIndicator (..),
  Value (..),
  ValueVariant (..),
 )
import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (..))
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 Data.Bifunctor (second)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as Base16
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity (runIdentity))
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, Word64)
import GHC.Generics (Generic)
import System.Random.Stateful (
  Random,
  RandomGen (genShortByteString, genWord32, genWord64),
  RandomGenM,
  StatefulGen (..),
  UniformRange (uniformRM),
  applyRandomGenM,
  randomM,
  uniformByteStringM,
 )

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

-- | Generator context, parametrised over the type of the random seed
data GenEnv g = GenEnv
  { forall {k} (g :: k). GenEnv g -> CTreeRoot' Identity MonoRef
cddl :: CTreeRoot' Identity MonoRef
  , forall {k} (g :: k). GenEnv g -> CapGenM g
fakeSeed :: CapGenM g
  -- ^ Access the "fake" seed, necessary to recursively call generators
  }
  deriving ((forall x. GenEnv g -> Rep (GenEnv g) x)
-> (forall x. Rep (GenEnv g) x -> GenEnv g) -> Generic (GenEnv g)
forall x. Rep (GenEnv g) x -> GenEnv g
forall x. GenEnv g -> Rep (GenEnv g) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (g :: k) x. Rep (GenEnv g) x -> GenEnv g
forall k (g :: k) x. GenEnv g -> Rep (GenEnv g) x
$cfrom :: forall k (g :: k) x. GenEnv g -> Rep (GenEnv g) x
from :: forall x. GenEnv g -> Rep (GenEnv g) x
$cto :: forall k (g :: k) x. Rep (GenEnv g) x -> GenEnv g
to :: forall x. Rep (GenEnv g) x -> GenEnv g
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)

newtype M g a = M {forall g a. M g a -> StateT (GenState g) (Reader (GenEnv g)) a
runM :: StateT (GenState g) (Reader (GenEnv g)) 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)
  deriving
    (HasSource "randomSeed" g, HasSink "randomSeed" g, HasState "randomSeed" g)
    via Field
          "randomSeed"
          ()
          (MonadState (StateT (GenState g) (Reader (GenEnv g))))
  deriving
    (HasSource "depth" Int, HasSink "depth" Int, HasState "depth" Int)
    via Field
          "depth"
          ()
          (MonadState (StateT (GenState g) (Reader (GenEnv g))))
  deriving
    ( HasSource "cddl" (CTreeRoot' Identity MonoRef)
    , HasReader "cddl" (CTreeRoot' Identity MonoRef)
    )
    via Field
          "cddl"
          ()
          (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g)))))
  deriving
    (HasSource "fakeSeed" (CapGenM g), HasReader "fakeSeed" (CapGenM g))
    via Field
          "fakeSeed"
          ()
          (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g)))))

-- | Opaque type carrying the type of a pure PRNG inside a capability-style
-- state monad.
data CapGenM g = CapGenM

instance RandomGen g => StatefulGen (CapGenM g) (M g) where
  uniformWord64 :: CapGenM g -> M g Word64
uniformWord64 CapGenM g
_ = forall {k} (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall (tag :: Symbol) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
state @"randomSeed" g -> (Word64, g)
forall g. RandomGen g => g -> (Word64, g)
genWord64
  uniformWord32 :: CapGenM g -> M g Word32
uniformWord32 CapGenM g
_ = forall {k} (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall (tag :: Symbol) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
state @"randomSeed" g -> (Word32, g)
forall g. RandomGen g => g -> (Word32, g)
genWord32

  uniformShortByteString :: Int -> CapGenM g -> M g ShortByteString
uniformShortByteString Int
n CapGenM g
_ = forall {k} (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall (tag :: Symbol) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
state @"randomSeed" (Int -> g -> (ShortByteString, g)
forall g. RandomGen g => Int -> g -> (ShortByteString, g)
genShortByteString Int
n)

instance RandomGen r => RandomGenM (CapGenM r) r (M r) where
  applyRandomGenM :: forall a. (r -> (a, r)) -> CapGenM r -> M r a
applyRandomGenM r -> (a, r)
f CapGenM r
_ = forall {k} (tag :: k) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
forall (tag :: Symbol) s (m :: * -> *) a.
HasState tag s m =>
(s -> (a, s)) -> m a
state @"randomSeed" r -> (a, r)
f

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

evalGen :: M g a -> GenEnv g -> GenState g -> a
evalGen :: forall g a. M g a -> GenEnv g -> GenState g -> a
evalGen M g a
m GenEnv g
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 g -> GenState g -> (a, GenState g)
forall g a. M g a -> GenEnv g -> GenState g -> (a, GenState g)
runGen M g a
m GenEnv g
env

asksM :: forall tag r m a. HasReader tag r m => (r -> m a) -> m a
asksM :: forall {k} (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
asksM r -> m a
f = r -> m a
f (r -> m a) -> m r -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
ask @tag

--------------------------------------------------------------------------------
-- 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 = forall {k} (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
forall (tag :: Symbol) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
asksM @"fakeSeed" ((CapGenM g -> M g a) -> M g a)
-> ((a, a) -> CapGenM g -> M g a) -> (a, a) -> M g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> CapGenM 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

-- | 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
  CapGenM g
fs <- forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall (tag :: Symbol) r (m :: * -> *). HasReader tag r m => m r
ask @"fakeSeed"
  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) -> CapGenM 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)
bounds CapGenM g
fs)
  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 = forall {k} (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
forall (tag :: Symbol) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
asksM @"fakeSeed" CapGenM g -> M g a
forall g r (m :: * -> *) a.
(RandomGenM g r m, Random a) =>
g -> m a
randomM

genBytes :: forall g. RandomGen g => Int -> M g ByteString
genBytes :: forall g. RandomGen g => Int -> M g ByteString
genBytes Int
n = forall {k} (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
forall (tag :: Symbol) r (m :: * -> *) a.
HasReader tag r m =>
(r -> m a) -> m a
asksM @"fakeSeed" ((CapGenM g -> M g ByteString) -> M g ByteString)
-> (CapGenM g -> M g ByteString) -> M g ByteString
forall a b. (a -> b) -> a -> b
$ Int -> CapGenM g -> M g ByteString
forall g (m :: * -> *). StatefulGen g m => Int -> g -> m ByteString
uniformByteStringM Int
n

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 -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (String -> String) -> ([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
--------------------------------------------------------------------------------

data WrappedTerm
  = SingleTerm Term
  | PairTerm Term Term
  | GroupTerm [WrappedTerm]
  deriving (WrappedTerm -> WrappedTerm -> Bool
(WrappedTerm -> WrappedTerm -> Bool)
-> (WrappedTerm -> WrappedTerm -> Bool) -> Eq WrappedTerm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WrappedTerm -> WrappedTerm -> Bool
== :: WrappedTerm -> WrappedTerm -> Bool
$c/= :: WrappedTerm -> WrappedTerm -> Bool
/= :: WrappedTerm -> WrappedTerm -> Bool
Eq, Int -> WrappedTerm -> String -> String
[WrappedTerm] -> String -> String
WrappedTerm -> String
(Int -> WrappedTerm -> String -> String)
-> (WrappedTerm -> String)
-> ([WrappedTerm] -> String -> String)
-> Show WrappedTerm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WrappedTerm -> String -> String
showsPrec :: Int -> WrappedTerm -> String -> String
$cshow :: WrappedTerm -> String
show :: WrappedTerm -> String
$cshowList :: [WrappedTerm] -> String -> String
showList :: [WrappedTerm] -> String -> String
Show)

-- | Recursively flatten wrapped list. That is, expand any groups out to their
-- individual entries.
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
flattenWrappedList [] = []
flattenWrappedList (GroupTerm [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

pattern S :: Term -> WrappedTerm
pattern $mS :: forall {r}. WrappedTerm -> (Term -> r) -> ((# #) -> r) -> r
$bS :: Term -> WrappedTerm
S t = SingleTerm t

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

pattern P :: Term -> Term -> WrappedTerm
pattern $mP :: forall {r}. WrappedTerm -> (Term -> Term -> r) -> ((# #) -> r) -> r
$bP :: Term -> Term -> WrappedTerm
P t1 t2 = PairTerm t1 t2

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

pattern G :: [WrappedTerm] -> WrappedTerm
pattern $mG :: forall {r}.
WrappedTerm -> ([WrappedTerm] -> r) -> ((# #) -> r) -> r
$bG :: [WrappedTerm] -> WrappedTerm
G xs = GroupTerm xs

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

genForCTree :: RandomGen g => CTree MonoRef -> M g WrappedTerm
genForCTree :: forall g. RandomGen g => CTree MonoRef -> 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 [Node MonoRef]
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
<$> (Node MonoRef -> M g WrappedTerm)
-> [Node MonoRef] -> 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 Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode [Node MonoRef]
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 [Node MonoRef]
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
<$> (Node MonoRef -> M g WrappedTerm)
-> [Node MonoRef] -> 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 Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode [Node MonoRef]
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 (Node MonoRef) -> [Node MonoRef]
forall a. NonEmpty a -> [a]
NE.toList -> [Node MonoRef]
nodes)) = do
  Int
ix <- (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
0, [Node MonoRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node MonoRef]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode (Node MonoRef -> M g WrappedTerm)
-> Node MonoRef -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [Node MonoRef]
nodes [Node MonoRef] -> Int -> Node MonoRef
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
genForCTree (CTree.Group [Node MonoRef]
nodes) = [WrappedTerm] -> WrappedTerm
G ([WrappedTerm] -> WrappedTerm)
-> M g [WrappedTerm] -> M g WrappedTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node MonoRef -> M g WrappedTerm)
-> [Node MonoRef] -> 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 Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode [Node MonoRef]
nodes
genForCTree (CTree.KV Node MonoRef
key Node MonoRef
value Bool
_cut) = do
  WrappedTerm
kg <- Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
key
  WrappedTerm
vg <- Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
key
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" => "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
value
genForCTree (CTree.Occur Node MonoRef
item OccurrenceIndicator
occurs) =
  OccurrenceIndicator -> M g WrappedTerm -> M g WrappedTerm
forall g.
RandomGen g =>
OccurrenceIndicator -> M g WrappedTerm -> M g WrappedTerm
applyOccurenceIndicator OccurrenceIndicator
occurs (Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
item)
genForCTree (CTree.Range Node MonoRef
from Node MonoRef
to RangeBound
_bounds) = do
  -- TODO Handle bounds correctly
  WrappedTerm
term1 <- Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
from
  WrappedTerm
term2 <- Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
to
  case (WrappedTerm
term1, WrappedTerm
term2) of
    (S (TInt Int
a), S (TInt 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)) -> (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, 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, 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, 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, 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, WrappedTerm)
x -> 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 range operator to non-numeric types: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (WrappedTerm, WrappedTerm) -> String
forall a. Show a => a -> String
show (WrappedTerm, WrappedTerm)
x
genForCTree (CTree.Control CtlOp
op Node MonoRef
target Node MonoRef
controller) = do
  CTree MonoRef
tt <- Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
target
  CTree MonoRef
ct <- Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
controller
  case (CtlOp
op, CTree MonoRef
ct) of
    (CtlOp
CtlOp.Le, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoRef
tt 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 MonoRef
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply le operator to target"
    (CtlOp
CtlOp.Le, CTree MonoRef
_) -> 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
controller
    (CtlOp
CtlOp.Lt, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoRef
tt 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 MonoRef
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply lt operator to target"
    (CtlOp
CtlOp.Lt, CTree MonoRef
_) -> 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
controller
    (CtlOp
CtlOp.Size, CTree.Literal (Value (VUInt Word64
n) Comment
_)) -> case CTree MonoRef
tt 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 MonoRef
_ -> String -> M g WrappedTerm
forall a. HasCallStack => String -> a
error String
"Cannot apply size operator to target "
    (CtlOp
CtlOp.Size, CTree.Range {Node MonoRef
from :: Node MonoRef
from :: forall (f :: * -> *). CTree f -> Node f
CTree.from, Node MonoRef
to :: Node MonoRef
to :: forall (f :: * -> *). CTree f -> Node f
CTree.to}) -> do
      CTree MonoRef
f <- Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
from
      CTree MonoRef
t <- Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
to
      case (CTree MonoRef
f, CTree MonoRef
t) of
        (CTree.Literal (Value (VUInt Word64
f1) Comment
_), CTree.Literal (Value (VUInt Word64
t1) Comment
_)) -> case CTree MonoRef
tt 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 MonoRef
_ -> 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> CTree MonoRef -> String
forall a. Show a => a -> String
show CTree MonoRef
tt
        (CTree MonoRef, CTree MonoRef)
_ ->
          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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
controller
    (CtlOp
CtlOp.Size, CTree MonoRef
_) ->
      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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Node MonoRef -> String
forall a. Show a => a -> String
show Node MonoRef
controller
    (CtlOp
CtlOp.Cbor, CTree MonoRef
_) -> do
      WrappedTerm
enc <- CTree MonoRef -> M g WrappedTerm
forall g. RandomGen g => CTree MonoRef -> M g WrappedTerm
genForCTree CTree MonoRef
ct
      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 MonoRef)
_ -> Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
target
genForCTree (CTree.Enum Node MonoRef
node) = do
  CTree MonoRef
tree <- Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
node
  case CTree MonoRef
tree of
    CTree.Group [Node MonoRef]
nodes -> do
      Int
ix <- (Int, Int) -> M g Int
forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a
genUniformRM (Int
0, [Node MonoRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node MonoRef]
nodes)
      Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode (Node MonoRef -> M g WrappedTerm)
-> Node MonoRef -> M g WrappedTerm
forall a b. (a -> b) -> a -> b
$ [Node MonoRef]
nodes [Node MonoRef] -> Int -> Node MonoRef
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix
    CTree MonoRef
_ -> 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 Node MonoRef
node) = CTree MonoRef -> M g WrappedTerm
forall g. RandomGen g => CTree MonoRef -> M g WrappedTerm
genForCTree (CTree MonoRef -> M g WrappedTerm)
-> M g (CTree MonoRef) -> M g WrappedTerm
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef Node MonoRef
node
genForCTree (CTree.Tag Word64
tag Node MonoRef
node) = do
  WrappedTerm
enc <- Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode Node MonoRef
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"

genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm
genForNode :: forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode = CTree MonoRef -> M g WrappedTerm
forall g. RandomGen g => CTree MonoRef -> M g WrappedTerm
genForCTree (CTree MonoRef -> M g WrappedTerm)
-> (Node MonoRef -> M g (CTree MonoRef))
-> Node MonoRef
-> M g WrappedTerm
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef

-- | Take something which might be a reference and resolve it to the relevant
-- Tree, following multiple links if necessary.
resolveIfRef :: RandomGen g => CTree.Node MonoRef -> M g (CTree MonoRef)
resolveIfRef :: forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef (MIt CTree MonoRef
a) = CTree MonoRef -> M g (CTree MonoRef)
forall a. a -> M g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CTree MonoRef
a
resolveIfRef (MRuleRef Name
n) = do
  (CTreeRoot Map Name (Identity (Node MonoRef))
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 (Identity (Node MonoRef))
-> Maybe (Identity (Node MonoRef))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Identity (Node MonoRef))
cddl of
    Maybe (Identity (Node MonoRef))
Nothing -> String -> M g (CTree MonoRef)
forall a. HasCallStack => String -> a
error (String -> M g (CTree MonoRef)) -> String -> M g (CTree MonoRef)
forall a b. (a -> b) -> a -> b
$ String
"Unbound reference: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
    Just Identity (Node MonoRef)
val -> Node MonoRef -> M g (CTree MonoRef)
forall g. RandomGen g => Node MonoRef -> M g (CTree MonoRef)
resolveIfRef (Node MonoRef -> M g (CTree MonoRef))
-> Node MonoRef -> M g (CTree MonoRef)
forall a b. (a -> b) -> a -> b
$ Identity (Node MonoRef) -> Node MonoRef
forall a. Identity a -> a
runIdentity Identity (Node MonoRef)
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 :: RandomGen g => Name -> M g Term
genForName :: forall g. RandomGen g => Name -> M g Term
genForName Name
n = do
  (CTreeRoot Map Name (Identity (Node MonoRef))
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 (Identity (Node MonoRef))
-> Maybe (Identity (Node MonoRef))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Identity (Node MonoRef))
cddl of
    Maybe (Identity (Node MonoRef))
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
    Just Identity (Node MonoRef)
val ->
      Node MonoRef -> M g WrappedTerm
forall g. RandomGen g => Node MonoRef -> M g WrappedTerm
genForNode (Identity (Node MonoRef) -> Node MonoRef
forall a. Identity a -> a
runIdentity Identity (Node MonoRef)
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
              String -> String -> String
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 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 Maybe Word64
mlb :: Word64, Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
10 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

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) = case ByteString -> Either String ByteString
Base16.decode ByteString
b of
  Right ByteString
bHex -> 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
bHex
  Left String
err -> 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
"Unable to parse hex encoded bytestring: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
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 :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> Term
generateCBORTerm :: forall g.
RandomGen g =>
CTreeRoot' Identity MonoRef -> Name -> g -> Term
generateCBORTerm CTreeRoot' Identity MonoRef
cddl Name
n g
stdGen =
  let genEnv :: GenEnv g
genEnv = GenEnv {CTreeRoot' Identity MonoRef
cddl :: CTreeRoot' Identity MonoRef
cddl :: CTreeRoot' Identity MonoRef
cddl, fakeSeed :: CapGenM g
fakeSeed = CapGenM g
forall {k} (g :: k). CapGenM g
CapGenM}
      genState :: GenState g
genState = GenState {randomSeed :: g
randomSeed = g
stdGen, depth :: Int
depth = Int
1}
   in M g Term -> GenEnv g -> GenState g -> Term
forall g a. M g a -> GenEnv g -> GenState g -> a
evalGen (Name -> M g Term
forall g. RandomGen g => Name -> M g Term
genForName Name
n) GenEnv g
genEnv GenState g
genState

generateCBORTerm' :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
generateCBORTerm' :: forall g.
RandomGen g =>
CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
generateCBORTerm' CTreeRoot' Identity MonoRef
cddl Name
n g
stdGen =
  let genEnv :: GenEnv g
genEnv = GenEnv {CTreeRoot' Identity MonoRef
cddl :: CTreeRoot' Identity MonoRef
cddl :: CTreeRoot' Identity MonoRef
cddl, fakeSeed :: CapGenM g
fakeSeed = CapGenM g
forall {k} (g :: k). CapGenM g
CapGenM}
      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 g -> GenState g -> (Term, GenState g)
forall g a. M g a -> GenEnv g -> GenState g -> (a, GenState g)
runGen (Name -> M g Term
forall g. RandomGen g => Name -> M g Term
genForName Name
n) GenEnv g
genEnv GenState g
genState