Gen.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Utilities for arbitrary data generation in property tests.
--
--   == Deprecation Notice
--
--   At the moment, this module exposes both Hedgehog generators and QuickCheck `Arbitrary`
--   instances for convenience.
--   However, `Arbitrary` instances should be considered deprecated and will eventually be removed.

module Michelson.Test.Gen
  ( minTimestamp
  , maxTimestamp
  , midTimestamp
  , genMutez
  , genTimestamp
  , genValueKeyHash
  , genValueMutez
  , genValueInt
  , genValueList
  , genValueUnit
  , genValuePair
  , genValueTimestamp
  ) where

import Data.Time.Calendar (Day, addDays, diffDays)
import Data.Time.Clock (UTCTime(..))
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.QuickCheck (Arbitrary(..), choose)

import Michelson.Typed (KnownT, T(..), Value'(..))
import Tezos.Core
  (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,
  unsafeMkMutez)
import Tezos.Crypto (genKeyHash)

instance Arbitrary (Value' instr 'TKeyHash) where
  arbitrary = VKeyHash <$> arbitrary
instance Arbitrary (Value' instr 'TMutez) where
  arbitrary = VMutez <$> arbitrary
instance Arbitrary (Value' instr 'TInt) where
  arbitrary = VInt <$> arbitrary
instance (KnownT a, Arbitrary (Value' instr a)) =>
         Arbitrary (Value' instr ('TList a)) where
  arbitrary = VList <$> arbitrary
instance Arbitrary (Value' instr 'TUnit) where
  arbitrary = pure VUnit
instance (Arbitrary (Value' instr a), Arbitrary (Value' instr b))
    => Arbitrary (Value' instr ('TPair a b)) where
  arbitrary = VPair ... (,) <$> arbitrary <*> arbitrary

genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash)
genValueKeyHash = VKeyHash <$> genKeyHash

genValueMutez :: MonadGen m => m (Value' instr 'TMutez)
genValueMutez = VMutez <$> genMutez

genValueInt :: MonadGen m => m (Value' instr 'TInt)
genValueInt = VInt <$> Gen.integral (Range.linearFrom 0 -1000 1000)

genValueList :: (MonadGen m, KnownT a) => m (Value' instr a) -> m (Value' instr ('TList a))
genValueList genA = VList <$> Gen.list (Range.linear 0 100) genA

genValueUnit :: Applicative m => m (Value' instr 'TUnit)
genValueUnit = pure VUnit

genValuePair :: MonadGen m => m (Value' instr a) -> m (Value' instr b) -> m (Value' instr ('TPair a b))
genValuePair genA genB = VPair ... (,) <$> genA <*> genB


minDay :: Day
minDay = fromMaybe (error "failed to parse day 2008-11-01") $
            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01"

maxDay :: Day
maxDay = fromMaybe (error "failed to parse day 2024-11-01") $
            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01"

minSec :: Integer
minSec = 0

maxSec :: Integer
maxSec = 86399

-- | Minimal (earliest) timestamp used for @Arbitrary (CValue 'CTimestamp)@
minTimestamp :: Timestamp
minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromInteger minSec)

-- | Maximal (latest) timestamp used for @Arbitrary (CValue 'CTimestamp)@
maxTimestamp :: Timestamp
maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromInteger maxSec)

-- | Median of 'minTimestamp' and 'maxTimestamp'.
-- Useful for testing (exactly half of generated dates will be before and after
-- this date).
midTimestamp :: Timestamp
midTimestamp = timestampFromUTCTime $
  UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay)
          (fromInteger $ (maxSec - minSec) `div` 2)

instance Arbitrary (Value' instr 'TTimestamp) where
  arbitrary = VTimestamp <$> arbitrary

instance Arbitrary Mutez where
  arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)

instance Arbitrary Timestamp where
  arbitrary =
    timestampFromSeconds <$>
    choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp)

genValueTimestamp :: MonadGen m => m (Value' instr 'TTimestamp)
genValueTimestamp = VTimestamp <$> genTimestamp

genMutez :: MonadGen m => m Mutez
genMutez = unsafeMkMutez <$> Gen.word64 (Range.linear (unMutez minBound) (unMutez maxBound))

genTimestamp :: MonadGen m => m Timestamp
genTimestamp =
  timestampFromSeconds <$> Gen.integral
    (Range.linear (timestampToSeconds minTimestamp) (timestampToSeconds maxTimestamp))