Micheline.hs

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

module Hedgehog.Gen.Morley.Micheline
  ( genExpression
  , genExpressionInt
  , genExpressionString
  , genExpressionBytes
  , genExpressionSeq
  , genExpressionPrim
  , genMichelinePrimAp
  , genExprAnnotation
  ) where

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

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

import Hedgehog.Range.Defaults

genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression
genExpression = Gen.recursive @m Gen.choice
  [genExpressionInt def, genExpressionString def, genExpressionBytes def]
  [genExpressionSeq def, genExpressionPrim]

genExpressionInt :: MonadGen f => Range ExpressionInt -> f Expression
genExpressionInt range = ExpressionInt <$> Gen.integral (unExpressionInt <$> range)

genExpressionString :: MonadGen f => Range SmallLength -> f Expression
genExpressionString rangeLen =
  ExpressionString <$> (Gen.text (unSmallLength <$> rangeLen) Gen.unicodeAll)

genExpressionBytes :: MonadGen f => Range Length -> f Expression
genExpressionBytes rangeLen = ExpressionBytes <$> Gen.bytes (unLength <$> rangeLen)

genExpressionSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m Expression
genExpressionSeq = fmap ExpressionSeq . genSeq

genSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m [Expression]
genSeq rangeLen = Gen.list (unSmallLength <$> rangeLen) genExpression

genExpressionPrim :: (MonadGen m, GenBase m ~ Identity) => m Expression
genExpressionPrim = ExpressionPrim <$> genMichelinePrimAp

genMichelinePrimAp :: (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp
genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genSeq def <*> genAnnots
  where
    genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive)
    genAnnots = Gen.list (unSmallLength <$> def) genExprAnnotation

genExprAnnotation :: (MonadGen m, GenBase m ~ Identity) => m Annotation
genExprAnnotation =  Gen.choice
  [genAnnotationType, genAnnotationVariable, genAnnotationField]
  where
    genAnnotationType = AnnotationType <$> genAnnotation
    genAnnotationVariable = AnnotationVariable <$> genAnnotation
    genAnnotationField = AnnotationField <$> genAnnotation