-- 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 qualified as Range

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

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
forall (m :: * -> *). MonadGen m => m LetName
genLetName)
      , (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
forall (m :: * -> *). MonadGen m => m LetName
genLetName)
      ]

genLetName :: MonadGen m => m LetName
genLetName :: m LetName
genLetName = 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 (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
3) 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
<$> m Pos
forall (m :: * -> *). MonadGen m => m Pos
genPos m (Pos -> SrcPos) -> m Pos -> m SrcPos
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Pos
forall (m :: * -> *). MonadGen m => m Pos
genPos

genPos :: MonadGen m => m Pos
genPos :: m Pos
genPos = 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 Range Word
forall a. (Bounded a, Integral a) => Range a
Range.linearBounded

genMText :: MonadGen m => m MText
genMText :: m MText
genMText =
  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
    (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
100)
    (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))