-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Hedgehog.Gen.Morley.Micheline
  ( -- * 'Expression' generators
    genExpression
  , genExpressionInt
  , genExpressionString
  , genExpressionBytes
  , genExpressionSeq
  , genExpressionPrim

    -- * Generic 'Exp' generators
  , genExp
  , genExpInt
  , genExpString
  , genExpBytes
  , genExpSeq
  , genExpPrim
  , genMichelinePrimAp
  , genExprAnnotation
  ) where

import Hedgehog (MonadGen(GenBase))
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range (Range)

import Hedgehog.Gen.Michelson.Untyped (genAnnotation)
import Hedgehog.Range.Defaults
import Morley.Micheline.Expression

----------------------------------------------------------------------------
-- Expression generators
----------------------------------------------------------------------------

genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression
genExpression :: forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Expression
genExpression = Maybe (m (XExp RegularExp))
-> Maybe (m (XExp RegularExp))
-> ExpExtras m RegularExp
-> m Expression
forall (x :: ExpExtensionDescriptorKind) (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
Maybe (m (XExp x))
-> Maybe (m (XExp x)) -> ExpExtras m x -> m (Exp x)
genExp Maybe (m (XExp RegularExp))
forall a. Maybe a
Nothing Maybe (m (XExp RegularExp))
forall a. Maybe a
Nothing (m () -> ExpExtras m RegularExp
forall extra (x :: ExpExtensionDescriptorKind) (f :: * -> *).
(extra ~ XExpInt x, extra ~ XExpString x, extra ~ XExpBytes x,
 extra ~ XExpSeq x, extra ~ XExpPrim x) =>
f extra -> ExpExtras f x
mkUniformExpExtras m ()
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded)

genExpressionInt :: MonadGen m => Range ExpressionInt -> m Expression
genExpressionInt :: forall (m :: * -> *).
MonadGen m =>
Range ExpressionInt -> m Expression
genExpressionInt = m (XExpInt RegularExp) -> Range ExpressionInt -> m Expression
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpInt x) -> Range ExpressionInt -> m (Exp x)
genExpInt (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

genExpressionString :: MonadGen m => Range SmallLength -> m Expression
genExpressionString :: forall (m :: * -> *).
MonadGen m =>
Range SmallLength -> m Expression
genExpressionString = m (XExpString RegularExp) -> Range SmallLength -> m Expression
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpString x) -> Range SmallLength -> m (Exp x)
genExpString (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

genExpressionBytes :: MonadGen m => Range Length -> m Expression
genExpressionBytes :: forall (m :: * -> *). MonadGen m => Range Length -> m Expression
genExpressionBytes = m (XExpBytes RegularExp) -> Range Length -> m Expression
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpBytes x) -> Range Length -> m (Exp x)
genExpBytes (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

genExpressionSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m Expression
genExpressionSeq :: forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
Range SmallLength -> m Expression
genExpressionSeq = m Expression
-> m (XExpSeq RegularExp) -> Range SmallLength -> m Expression
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x)
genExpSeq m Expression
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Expression
genExpression (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

genExpressionPrim :: (MonadGen m, GenBase m ~ Identity) => m Expression
genExpressionPrim :: forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Expression
genExpressionPrim = m Expression -> m (XExpPrim RegularExp) -> m Expression
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
(MonadGen m, GenBase m ~ Identity) =>
m (Exp x) -> m (XExpPrim x) -> m (Exp x)
genExpPrim m Expression
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Expression
genExpression (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

----------------------------------------------------------------------------
-- Generic Exp generators
----------------------------------------------------------------------------

-- | Generate extended expression given the generators for all the extension
-- points.
--
-- In case your expression has no extra constructors, avoid supplying
-- @Just 'Gen.discard'@ as that would cause the generator to give up
-- periodically (supply 'Nothing' instead).
genExp
  :: forall x m. (MonadGen m, GenBase m ~ Identity)
  => Maybe (m (XExp x))
     -- ^ Non-recursive extra constructors
  -> Maybe (m (XExp x))
     -- ^ Recursive extra constructors (that can generate @Exp@ inside)
  -> ExpExtras m x
  -> m (Exp x)
genExp :: forall (x :: ExpExtensionDescriptorKind) (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
Maybe (m (XExp x))
-> Maybe (m (XExp x)) -> ExpExtras m x -> m (Exp x)
genExp Maybe (m (XExp x))
mGenXCon Maybe (m (XExp x))
mGenXConRec ExpExtras m x
xGens = ([m (Exp x)] -> m (Exp x))
-> [m (Exp x)] -> [m (Exp x)] -> m (Exp x)
forall (m :: * -> *) a.
MonadGen m =>
([m a] -> m a) -> [m a] -> [m a] -> m a
Gen.recursive [m (Exp x)] -> m (Exp x)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
  ( ([m (Exp x)] -> [m (Exp x)])
-> (m (Exp x) -> [m (Exp x)] -> [m (Exp x)])
-> Maybe (m (Exp x))
-> [m (Exp x)]
-> [m (Exp x)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [m (Exp x)] -> [m (Exp x)]
forall a. a -> a
id (:) (XExp x -> Exp x
forall (x :: ExpExtensionDescriptorKind). XExp x -> Exp x
ExpX (XExp x -> Exp x) -> Maybe (m (XExp x)) -> Maybe (m (Exp x))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> Maybe (m (XExp x))
mGenXCon)
    [ m (XExpInt x) -> Range ExpressionInt -> m (Exp x)
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpInt x) -> Range ExpressionInt -> m (Exp x)
genExpInt (ExpExtras m x -> m (XExpInt x)
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpInt x)
eeInt ExpExtras m x
xGens) Range ExpressionInt
forall a. Default a => a
def
    , m (XExpString x) -> Range SmallLength -> m (Exp x)
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpString x) -> Range SmallLength -> m (Exp x)
genExpString (ExpExtras m x -> m (XExpString x)
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpString x)
eeString ExpExtras m x
xGens) Range SmallLength
forall a. Default a => a
def
    , m (XExpBytes x) -> Range Length -> m (Exp x)
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpBytes x) -> Range Length -> m (Exp x)
genExpBytes (ExpExtras m x -> m (XExpBytes x)
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpBytes x)
eeBytes ExpExtras m x
xGens) Range Length
forall a. Default a => a
def
    ]
  )
  ( ([m (Exp x)] -> [m (Exp x)])
-> (m (Exp x) -> [m (Exp x)] -> [m (Exp x)])
-> Maybe (m (Exp x))
-> [m (Exp x)]
-> [m (Exp x)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [m (Exp x)] -> [m (Exp x)]
forall a. a -> a
id (:) (XExp x -> Exp x
forall (x :: ExpExtensionDescriptorKind). XExp x -> Exp x
ExpX (XExp x -> Exp x) -> Maybe (m (XExp x)) -> Maybe (m (Exp x))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> Maybe (m (XExp x))
mGenXConRec)
    [m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x)
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x)
genExpSeq m (Exp x)
runRec (ExpExtras m x -> m (XExpSeq x)
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpSeq x)
eeSeq ExpExtras m x
xGens) Range SmallLength
forall a. Default a => a
def, m (Exp x) -> m (XExpPrim x) -> m (Exp x)
forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
(MonadGen m, GenBase m ~ Identity) =>
m (Exp x) -> m (XExpPrim x) -> m (Exp x)
genExpPrim m (Exp x)
runRec (ExpExtras m x -> m (XExpPrim x)
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpPrim x)
eePrim ExpExtras m x
xGens)]
  )
  where
    runRec :: m (Exp x)
runRec = m (Exp x) -> (Exp x -> Exp x) -> m (Exp x)
forall (m :: * -> *) a. MonadGen m => m a -> (a -> a) -> m a
Gen.subterm (Maybe (m (XExp x))
-> Maybe (m (XExp x)) -> ExpExtras m x -> m (Exp x)
forall (x :: ExpExtensionDescriptorKind) (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
Maybe (m (XExp x))
-> Maybe (m (XExp x)) -> ExpExtras m x -> m (Exp x)
genExp Maybe (m (XExp x))
mGenXCon Maybe (m (XExp x))
mGenXConRec ExpExtras m x
xGens) Exp x -> Exp x
forall a. a -> a
id

genExpInt :: MonadGen m => m (XExpInt x) -> Range ExpressionInt -> m (Exp x)
genExpInt :: forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpInt x) -> Range ExpressionInt -> m (Exp x)
genExpInt m (XExpInt x)
genX Range ExpressionInt
range =
  XExpInt x -> Integer -> Exp x
forall (x :: ExpExtensionDescriptorKind).
XExpInt x -> Integer -> Exp x
ExpInt (XExpInt x -> Integer -> Exp x)
-> m (XExpInt x) -> m (Integer -> Exp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (XExpInt x)
genX m (Integer -> Exp x) -> m Integer -> m (Exp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Integer -> m Integer
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral (ExpressionInt -> Integer
unExpressionInt (ExpressionInt -> Integer) -> Range ExpressionInt -> Range Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range ExpressionInt
range)

genExpString :: MonadGen m => m (XExpString x) -> Range SmallLength -> m (Exp x)
genExpString :: forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpString x) -> Range SmallLength -> m (Exp x)
genExpString m (XExpString x)
genX Range SmallLength
rangeLen =
  XExpString x -> Text -> Exp x
forall (x :: ExpExtensionDescriptorKind).
XExpString x -> Text -> Exp x
ExpString (XExpString x -> Text -> Exp x)
-> m (XExpString x) -> m (Text -> Exp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (XExpString x)
genX m (Text -> Exp x) -> m Text -> m (Exp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Range Int -> m Char -> m Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text (SmallLength -> Int
unSmallLength (SmallLength -> Int) -> Range SmallLength -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SmallLength
rangeLen) m Char
forall (m :: * -> *). MonadGen m => m Char
Gen.unicodeAll)

genExpBytes :: MonadGen m => m (XExpBytes x) -> Range Length -> m (Exp x)
genExpBytes :: forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (XExpBytes x) -> Range Length -> m (Exp x)
genExpBytes m (XExpBytes x)
genX Range Length
rangeLen =
  XExpBytes x -> ByteString -> Exp x
forall (x :: ExpExtensionDescriptorKind).
XExpBytes x -> ByteString -> Exp x
ExpBytes (XExpBytes x -> ByteString -> Exp x)
-> m (XExpBytes x) -> m (ByteString -> Exp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (XExpBytes x)
genX m (ByteString -> Exp x) -> m ByteString -> m (Exp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> m ByteString
forall (m :: * -> *). MonadGen m => Range Int -> m ByteString
Gen.bytes (Length -> Int
unLength (Length -> Int) -> Range Length -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Length
rangeLen)

genExpSeq
  :: MonadGen m
  => m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x)
genExpSeq :: forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
MonadGen m =>
m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x)
genExpSeq m (Exp x)
doGenExp m (XExpSeq x)
genX Range SmallLength
rangeLen =
  XExpSeq x -> [Exp x] -> Exp x
forall (x :: ExpExtensionDescriptorKind).
XExpSeq x -> [Exp x] -> Exp x
ExpSeq (XExpSeq x -> [Exp x] -> Exp x)
-> m (XExpSeq x) -> m ([Exp x] -> Exp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (XExpSeq x)
genX m ([Exp x] -> Exp x) -> m [Exp x] -> m (Exp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> m (Exp x) -> m [Exp x]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (SmallLength -> Int
unSmallLength (SmallLength -> Int) -> Range SmallLength -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SmallLength
rangeLen) m (Exp x)
doGenExp

genExpPrim
  :: (MonadGen m, GenBase m ~ Identity)
  => m (Exp x) -> m (XExpPrim x) -> m (Exp x)
genExpPrim :: forall (m :: * -> *) (x :: ExpExtensionDescriptorKind).
(MonadGen m, GenBase m ~ Identity) =>
m (Exp x) -> m (XExpPrim x) -> m (Exp x)
genExpPrim m (Exp x)
doGenExp m (XExpPrim x)
genX = XExpPrim x -> MichelinePrimAp x -> Exp x
forall (x :: ExpExtensionDescriptorKind).
XExpPrim x -> MichelinePrimAp x -> Exp x
ExpPrim (XExpPrim x -> MichelinePrimAp x -> Exp x)
-> m (XExpPrim x) -> m (MichelinePrimAp x -> Exp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (XExpPrim x)
genX m (MichelinePrimAp x -> Exp x)
-> m (MichelinePrimAp x) -> m (Exp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Exp x) -> m (MichelinePrimAp x)
forall (x :: ExpExtensionDescriptorKind) (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m (Exp x) -> m (MichelinePrimAp x)
genMichelinePrimAp m (Exp x)
doGenExp

genMichelinePrimAp :: forall x m. (MonadGen m, GenBase m ~ Identity) => m (Exp x) -> m (MichelinePrimAp x)
genMichelinePrimAp :: forall (x :: ExpExtensionDescriptorKind) (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m (Exp x) -> m (MichelinePrimAp x)
genMichelinePrimAp m (Exp x)
doGenExp =
  MichelinePrimitive -> [Exp x] -> [Annotation] -> MichelinePrimAp x
forall (x :: ExpExtensionDescriptorKind).
MichelinePrimitive -> [Exp x] -> [Annotation] -> MichelinePrimAp x
MichelinePrimAp
    (MichelinePrimitive
 -> [Exp x] -> [Annotation] -> MichelinePrimAp x)
-> m MichelinePrimitive
-> m ([Exp x] -> [Annotation] -> MichelinePrimAp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MichelinePrimitive
genMichelinePrimitive
    m ([Exp x] -> [Annotation] -> MichelinePrimAp x)
-> m [Exp x] -> m ([Annotation] -> MichelinePrimAp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> m (Exp x) -> m [Exp x]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (SmallLength -> Int
unSmallLength (SmallLength -> Int) -> Range SmallLength -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SmallLength
forall a. Default a => a
def) m (Exp x)
doGenExp
    m ([Annotation] -> MichelinePrimAp x)
-> m [Annotation] -> m (MichelinePrimAp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [Annotation]
genAnnots
  where
    genMichelinePrimitive :: m MichelinePrimitive
genMichelinePrimitive = Text -> MichelinePrimitive
MichelinePrimitive (Text -> MichelinePrimitive) -> m Text -> m MichelinePrimitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text] -> m Text
forall (m :: * -> *) a. MonadGen m => [a] -> m a
Gen.element ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Seq Text -> [Element (Seq Text)]
forall t. Container t => t -> [Element t]
toList Seq Text
michelsonPrimitive)
    genAnnots :: m [Annotation]
genAnnots = Range Int -> m Annotation -> m [Annotation]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (SmallLength -> Int
unSmallLength (SmallLength -> Int) -> Range SmallLength -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SmallLength
forall a. Default a => a
def) m Annotation
forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Annotation
genExprAnnotation

genExprAnnotation :: (MonadGen m, GenBase m ~ Identity) => m Annotation
genExprAnnotation :: forall (m :: * -> *).
(MonadGen m, GenBase m ~ Identity) =>
m Annotation
genExprAnnotation =  [m Annotation] -> m Annotation
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
  [m Annotation
genAnnotationType, m Annotation
genAnnotationVariable, m Annotation
genAnnotationField]
  where
    genAnnotationType :: m Annotation
genAnnotationType = TypeAnn -> Annotation
AnnotationType (TypeAnn -> Annotation) -> m TypeAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TypeAnn
forall {k} (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation
    genAnnotationVariable :: m Annotation
genAnnotationVariable = VarAnn -> Annotation
AnnotationVariable (VarAnn -> Annotation) -> m VarAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VarAnn
forall {k} (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation
    genAnnotationField :: m Annotation
genAnnotationField = FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation) -> m FieldAnn -> m Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FieldAnn
forall {k} (m :: * -> *) (a :: k).
(MonadGen m, GenBase m ~ Identity) =>
m (Annotation a)
genAnnotation