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