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

module Hedgehog.Gen.Michelson
  ( genInstrCallStack
  , genLetName
  , genSrcPos
  , genPos
  , genMText
  ) where

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

import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..))
import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, mkMText)

import Hedgehog.Range.Defaults

genInstrCallStack :: MonadGen m => m InstrCallStack
genInstrCallStack :: m InstrCallStack
genInstrCallStack = LetCallStack -> SrcPos -> InstrCallStack
InstrCallStack (LetCallStack -> SrcPos -> InstrCallStack)
-> m LetCallStack -> m (SrcPos -> InstrCallStack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LetCallStack
genLetCallStack m (SrcPos -> InstrCallStack) -> m SrcPos -> m InstrCallStack
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m SrcPos
forall (m :: * -> *). MonadGen m => m SrcPos
genSrcPos
  where
    genLetCallStack :: m LetCallStack
genLetCallStack = [(Int, m LetCallStack)] -> m LetCallStack
forall (m :: * -> *) a. MonadGen m => [(Int, m a)] -> m a
Gen.frequency
      [ (Int
80, LetCallStack -> m LetCallStack
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
      , (Int
18, Range Int -> m LetName -> m LetCallStack
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Range Int
forall a. a -> Range a
Range.singleton Int
1) (m LetName -> m LetCallStack) -> m LetName -> m LetCallStack
forall a b. (a -> b) -> a -> b
$ Range TinyLength -> m LetName
forall (m :: * -> *). MonadGen m => Range TinyLength -> m LetName
genLetName Range TinyLength
forall a. Default a => a
def)
      , (Int
2, Range Int -> m LetName -> m LetCallStack
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Range Int
forall a. a -> Range a
Range.singleton Int
2) (m LetName -> m LetCallStack) -> m LetName -> m LetCallStack
forall a b. (a -> b) -> a -> b
$ Range TinyLength -> m LetName
forall (m :: * -> *). MonadGen m => Range TinyLength -> m LetName
genLetName Range TinyLength
forall a. Default a => a
def)
      ]

genLetName :: MonadGen m => Range TinyLength -> m LetName
genLetName :: Range TinyLength -> m LetName
genLetName Range TinyLength
lenRange =
  Text -> LetName
LetName (Text -> LetName) -> m Text -> m LetName
forall (f :: * -> *) a b. Functor 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 (TinyLength -> Int
unTinyLength (TinyLength -> Int) -> Range TinyLength -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range TinyLength
lenRange) m Char
forall (m :: * -> *). MonadGen m => m Char
Gen.unicodeAll

genSrcPos :: MonadGen m => m SrcPos
genSrcPos :: m SrcPos
genSrcPos = Pos -> Pos -> SrcPos
SrcPos (Pos -> Pos -> SrcPos) -> m Pos -> m (Pos -> SrcPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Pos -> m Pos
forall (m :: * -> *). MonadGen m => Range Pos -> m Pos
genPos Range Pos
forall a. Default a => a
def m (Pos -> SrcPos) -> m Pos -> m SrcPos
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Pos -> m Pos
forall (m :: * -> *). MonadGen m => Range Pos -> m Pos
genPos Range Pos
forall a. Default a => a
def

genPos :: MonadGen m => Range.Range Pos -> m Pos
genPos :: Range Pos -> m Pos
genPos Range Pos
range = Word -> Pos
Pos (Word -> Pos) -> m Word -> m Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word -> m Word
forall (m :: * -> *). MonadGen m => Range Word -> m Word
Gen.word (Pos -> Word
unPos (Pos -> Word) -> Range Pos -> Range Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Pos
range)

genMText :: MonadGen m => Range.Range Length -> m MText
genMText :: Range Length -> m MText
genMText Range Length
lenRange =
  Either Text MText -> MText
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text MText -> MText)
-> (Text -> Either Text MText) -> Text -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> MText) -> m Text -> m MText
forall (f :: * -> *) a b. Functor 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
    (Length -> Int
unLength (Length -> Int) -> Range Length -> Range Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Length
lenRange)
    (Char -> Char -> m Char
forall (m :: * -> *) a. (MonadGen m, Enum a) => a -> a -> m a
Gen.enum (Int -> Char
forall a. Enum a => Int -> a
toEnum @Char Int
minBoundMChar) (Int -> Char
forall a. Enum a => Int -> a
toEnum @Char Int
maxBoundMChar))