Value.hs

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

{-# LANGUAGE EmptyDataDeriving #-}

-- | Re-exports typed Value, CValue, some core types, some helpers and
-- defines aliases for constructors of typed values.
--
module Lorentz.Value
  ( M.Value
  , M.IsoValue (..)
  , M.WellTypedIsoValue

    -- * Primitive types
  , Integer
  , Natural
  , MText
  , Bool (..)
  , ByteString
  , Address
  , EpAddress (..)
  , Mutez
  , Never
  , Timestamp
  , ChainId
  , KeyHash
  , PublicKey
  , Signature
  , Bls12381Fr
  , Bls12381G1
  , Bls12381G2
  , Set
  , Map
  , M.BigMapId (..)
  , M.BigMap
  , M.mkBigMap
  , M.Operation
  , Maybe (..)
  , List
  , ReadTicket (..)
  , ContractRef (..)
  , TAddress (..)
  , FutureContract (..)
  , M.Ticket (..)
  , Chest
  , ChestKey
  , OpenChest

  , M.EpName
  , pattern M.DefEpName
  , M.EntrypointCall
  , M.SomeEntrypointCall

    -- * Custom datatypes
  , Fixed (..)
  , NFixed (..)
  , DecBase (..)
  , BinBase (..)

    -- * Constructors
  , tz
  , toMutez
  , zeroMutez
  , oneMutez
  , mt
  , timestampFromSeconds
  , timestampFromUTCTime
  , timestampQuote

    -- * Conversions
  , M.coerceContractRef
  , callingAddress
  , callingDefAddress
  , callingTAddress
  , callingDefTAddress
  , ToAddress (..)
  , ToTAddress (..)
  , ToContractRef (..)
  , FromContractRef (..)
  , convertContractRef

    -- * Misc
  , Show
  , Default (..)
  , Label (..)
  , PrintAsValue (..)

  -- * Re-exports
  , module ReExports
  ) where

import Data.Constraint ((\\))
import Data.Default (Default(..))
import Data.Fixed (Fixed(..), HasResolution(..))
import GHC.Num (fromInteger)
import Prelude hiding (fromInteger)
import Text.Show qualified

import Fmt (Buildable(..))

import Lorentz.Address
import Lorentz.Constraints.Scopes
import Lorentz.Wrappable
import Morley.AsRPC (HasRPCRepr(..))
import Morley.Michelson.Text
import Morley.Michelson.Typed qualified as M
import Morley.Michelson.Typed.Haskell.Compatibility as ReExports
import Morley.Tezos.Core
  (ChainId, Mutez, Timestamp, oneMutez, timestampFromSeconds, timestampFromUTCTime, timestampQuote,
  toMutez, tz, zeroMutez)
import Morley.Tezos.Crypto
  (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature)
import Morley.Util.CustomGeneric as ReExports
import Morley.Util.Label (Label(..))

import Lorentz.Annotation

type List = []

data Never
  deriving stock (Generic, Show, Eq, Ord)
  deriving anyclass (M.IsoValue, NFData)

instance Buildable Never where
  build = \case

instance HasAnnotation Never where
  getAnnotation _ = M.starNotes

instance HasRPCRepr Never where
  type AsRPC Never = Never

instance M.TypeHasDoc Never where
  typeDocMdDescription = "An uninhabited type."

-- | Value returned by @READ_TICKET@ instruction.
data ReadTicket a = ReadTicket
  { rtTicketer :: Address
  , rtData :: a
  , rtAmount :: Natural
  } deriving stock (Show, Eq, Ord)

customGeneric "ReadTicket" rightComb

deriving anyclass instance M.IsoValue a => M.IsoValue (ReadTicket a)

-- | Provides 'Buildable' instance that prints Lorentz value via Michelson's
-- 'M.Value'.
--
-- Result won't be very pretty, but this avoids requiring 'Show' or
-- 'Buildable' instances.
newtype PrintAsValue a = PrintAsValue a

instance NiceUntypedValue a => Buildable (PrintAsValue a) where
  build (PrintAsValue a) = build (M.toVal a) \\ niceUntypedValueEvi @a

-- | Datatypes, representing base of the fixed-point values
data DecBase p where
  DecBase :: KnownNat p => DecBase p
data BinBase p where
  BinBase :: KnownNat p => BinBase p

instance KnownNat p => HasResolution (DecBase p) where
  resolution _ = 10 ^ (natVal (Proxy @p))

instance KnownNat p => HasResolution (BinBase p) where
  resolution _ = 2 ^ (natVal (Proxy @p))

-- | Like @Fixed@ but with a @Natural@ value inside constructor
newtype NFixed p = MkNFixed Natural deriving stock (Eq, Ord)

convertNFixedToFixed :: NFixed a -> Fixed a
convertNFixedToFixed (MkNFixed a) = MkFixed (fromIntegral a)

instance (HasResolution a) => Show (NFixed a) where
  show = show . convertNFixedToFixed

-- Note: This instances are copies of those in Data.Fixed for Fixed datatype
instance (HasResolution a) => Num (NFixed a) where
  (MkNFixed a) + (MkNFixed b) = MkNFixed (a + b)
  (MkNFixed a) - (MkNFixed b) = MkNFixed (a - b)
  fa@(MkNFixed a) * (MkNFixed b) = MkNFixed (div (a * b) (fromInteger (resolution fa)))
  negate (MkNFixed a) = MkNFixed (negate a)
  abs = id
  signum (MkNFixed a) = MkNFixed (signum a)
  fromInteger i = withResolution (\res -> MkNFixed ((fromInteger i) * res))

instance (HasResolution a) => Fractional (NFixed a) where
  fa@(MkNFixed a) / (MkNFixed b) = MkNFixed (div (a * (fromInteger (resolution fa))) b)
  recip fa@(MkNFixed a) = MkNFixed (div (res * res) a) where
      res = fromInteger $ resolution fa
  fromRational r = withResolution (\res -> MkNFixed (floor (r * (toRational res))))

instance M.IsoValue (NFixed p) where
  type ToT (NFixed p) = 'M.TNat
  toVal (MkNFixed x) = M.VNat x
  fromVal (M.VNat x) = MkNFixed x

instance Unwrappable (NFixed a) where
  type Unwrappabled (NFixed a) = Natural

-- Helpers copied from Data.Fixed, because they are not exported from there
withResolution :: forall a f. (HasResolution a) => (Natural -> f a) -> f a
withResolution foo = foo . fromInteger . resolution $ Proxy @a

data OpenChest = ChestContent ByteString | ChestOpenFailed Bool
  deriving stock (Generic, Show, Eq)
  deriving anyclass (M.IsoValue, HasAnnotation)

instance HasRPCRepr OpenChest where
  type AsRPC OpenChest = OpenChest

instance M.TypeHasDoc OpenChest where
  typeDocMdDescription = "Result of opening a chest"