diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,48 @@ +0.13.3 +====== +* [!1100](https://gitlab.com/morley-framework/morley/-/merge_requests/1100) + Support `map` instruction over `Maybe` (a.k.a. `option`) + + Add `instance MapOpHs (Maybe e)` +* [!1084](https://gitlab.com/morley-framework/morley/-/merge_requests/1084) + Switch to the new mutez subtraction operation +* [!1101](https://gitlab.com/morley-framework/morley/-/merge_requests/1101) + Export `sopSetField` and `sopGetField` from `Lorentz.StoreClass` +* [!1089](https://gitlab.com/morley-framework/morley/-/merge_requests/1089) + Enhance and rename mutez quasiquote + + Export `tz` quasiquoter from `Lorentz.Value` and `Lorentz`. +* [!1071](https://gitlab.com/morley-framework/morley/-/merge_requests/1071) + Add `HasRPCRepr` typeclass + + Move `AsRPC` type instances from the `Lorentz.AsRPC` module + to the modules of their respective types. +* [!901](https://gitlab.com/morley-framework/morley/-/merge_requests/901) + Weaken constraints of `getField` + + `getField` and similar methods now require `Dupable` on the copied field and + `HasDupableGetters` (defaults to `Dupable`) on the datatype. +* [!1060](https://gitlab.com/morley-framework/morley/-/merge_requests/1060) + Add `Lorentz.AsRPC` module containing instances for `Morley.AsRPC` type family +* [!978](https://gitlab.com/morley-framework/morley/-/merge_requests/978) + Make it difficult to misuse 'Show' + + Use `Buildable` and `pretty` preferrentially. + + Avoid using `(+||)` and `(||+)`. + + Use `Debug.show` when defining `Show` instances. +* [!1062](https://gitlab.com/morley-framework/morley/-/merge_requests/1062) + Move `senderIsNotAdmin` Lorenz error to `morley-ledgers` repo +* [!997](https://gitlab.com/morley-framework/morley/-/merge_requests/997) + Check necessity in initial `cast` automatically in Lorentz contracts +* [!1043](https://gitlab.com/morley-framework/morley/-/merge_requests/1043) + Extract actual + expected pattern into a datatype and show diff in type mismatch +* [!1037](https://gitlab.com/morley-framework/morley/-/merge_requests/1037) + Add synonyms for `SomeConstrainedValue` + + Reimplement `SomeConstant`, `SomeValue`, `SomeStorage` via `SomeConstrainedValue`. + + Add `SomePackedVal = SomeConstrainedValue PackedValScope`. +* [!1049](https://gitlab.com/morley-framework/morley/-/merge_requests/1049) + Delete unnecessary `HasStorage` constraints + + `Lorentz.Contract` no longer requires `ParameterDeclaresEntrypoints` or `HasAnnotation st`. + + Added `NiceStorageFull` constraint for when `HasAnnotation st` is actually needed. + 0.13.2 ====== * [!1041](https://gitlab.com/morley-framework/morley/-/merge_requests/1041) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,6 @@ -MIT License Copyright (c) 2020 Tocqueville Group +MIT License +Copyright (c) 2021-2022 Oxhead Alpha +Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/lorentz.cabal b/lorentz.cabal --- a/lorentz.cabal +++ b/lorentz.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: lorentz -version: 0.13.2 +version: 0.13.3 synopsis: EDSL for the Michelson Language description: Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell. It has the same instructions as Michelson, but operates on Haskell values and allows one to use Haskell features. category: Language @@ -13,7 +13,7 @@ bug-reports: https://gitlab.com/morley-framework/morley/-/issues author: camlCase, Serokell, Tocqueville Group maintainer: Serokell -copyright: 2019-2021 Tocqueville Group +copyright: 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple @@ -50,7 +50,6 @@ Lorentz.Entrypoints.Impl Lorentz.Entrypoints.Manual Lorentz.Errors - Lorentz.Errors.Common Lorentz.Errors.Numeric Lorentz.Errors.Numeric.Contract Lorentz.Errors.Numeric.Doc @@ -60,6 +59,8 @@ Lorentz.FixedArith Lorentz.Instr Lorentz.Iso + Lorentz.Layouts + Lorentz.Layouts.NonDupable Lorentz.Macro Lorentz.OpSize Lorentz.Pack @@ -107,24 +108,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections diff --git a/src/Lorentz.hs b/src/Lorentz.hs --- a/src/Lorentz.hs +++ b/src/Lorentz.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Lorentz ( module Exports @@ -20,7 +19,6 @@ import Lorentz.Entrypoints as Exports import Lorentz.Entrypoints.Doc as Exports import Lorentz.Errors as Exports -import Lorentz.Errors.Common as Exports () import Lorentz.Errors.Numeric as Exports import Lorentz.Expr as Exports import Lorentz.Ext as Exports diff --git a/src/Lorentz/ADT.hs b/src/Lorentz/ADT.hs --- a/src/Lorentz/ADT.hs +++ b/src/Lorentz/ADT.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -11,6 +10,7 @@ , HasFieldsOfType , NamedField (..) , (:=) + , HasDupableGetters , toField , toFieldNamed , getField @@ -37,6 +37,10 @@ , Rec (..) , (:!) , (:?) + + -- * Advanced methods + , getFieldOpen + , setFieldOpen ) where import Data.Constraint ((\\)) @@ -48,7 +52,6 @@ import Lorentz.Constraints import Morley.Michelson.Typed.Haskell.Instr import Morley.Michelson.Typed.Haskell.Value -import Morley.Michelson.Typed.Instr import Morley.Util.Label (Label) import Morley.Util.Named import Morley.Util.Type (KnownList, type (++)) @@ -78,6 +81,36 @@ HasFieldsOfType dt ((n := ty) ': fs) = (HasFieldOfType dt n ty, HasFieldsOfType dt fs) +-- | This marker typeclass is a requirement for the 'getField' +-- (where it is imposed on the /datatype/), and it is supposed to be satisfied +-- in two cases: +-- +-- 1. The entire datatype is 'Dupable'; +-- 2. When the datatype has non-dupable fields, they are located so that +-- 'getField' remains efficient. +-- +-- The problem we are trying to solve here: without special care, 'getField' +-- may become multiple times more costly, see 'instrGetField' for the +-- explanation. +-- And this typeclass imposes an invariant: if we ever use 'getField' on a +-- datatype, then we have to pay attention to the datatype's Michelson +-- representation and ensure 'getField' remains optimal. +-- +-- When you are developing a contract: +-- "Lorentz.Layouts.NonDupable" module contains utilities to help you +-- provide the necessary Michelson layout. In case you want to use your +-- custom layout but still allow 'getField' for it, you can define an instance +-- for your type manually as an assurance that Michelson layout is optimal enough +-- to use 'getField' on this type. +-- +-- When you are developing a library: +-- Note that 'HasDupableGetters' resolves to 'Dupable' by default, and when +-- propagating this constraint you can switch to 'Dupable' anytime but this +-- will also make your code unusable in the presence of 'Ticket's and other +-- non-dupable types. +class HasDupableGetters a +instance {-# OVERLAPPABLE #-} Dupable a => HasDupableGetters a + -- | Extract a field of a datatype replacing the value of this -- datatype with the extracted field. -- @@ -97,22 +130,19 @@ toFieldNamed l = toField l # toNamed l -- | Extract a field of a datatype, leaving the original datatype on stack. --- --- TODO: [#585] Make this and all depending functions require only --- @Dupable (GetFieldType dt name)@ getField :: forall dt name st. - (InstrGetFieldC dt name, Dupable dt) + (InstrGetFieldC dt name, Dupable (GetFieldType dt name), HasDupableGetters dt) => Label name -> dt : st :-> GetFieldType dt name : dt ': st -getField l = dup # toField l +getField = I . instrGetField @dt + \\ dupableEvi @(GetFieldType dt name) where - dup :: forall a s. Dupable a => a : s :-> a : a : s - dup = I DUP \\ dupableEvi @a + _needHasDupableGetters = Dict @(HasDupableGetters dt) -- | Like 'getField', but leaves field named. getFieldNamed :: forall dt name st. - (InstrGetFieldC dt name, Dupable dt) + (InstrGetFieldC dt name, Dupable (GetFieldType dt name), HasDupableGetters dt) => Label name -> dt : st :-> (name :! GetFieldType dt name) : dt ': st getFieldNamed l = getField l # coerceWrap @@ -128,12 +158,51 @@ :: forall dt name st. ( InstrGetFieldC dt name , InstrSetFieldC dt name - , Dupable dt + , Dupable (GetFieldType dt name) + , HasDupableGetters dt ) => Label name -> (forall st0. (GetFieldType dt name ': st0) :-> (GetFieldType dt name ': st0)) -> dt : st :-> dt : st modifyField l i = getField @dt l # i # setField @dt l + +-- | \"Open\" version of 'getField', an advanced method suitable for chaining +-- getters. +-- +-- It accepts two continuations accepting the extracted field, one that +-- leaves the field on stack (and does a duplication of @res@ inside) +-- and another one that consumes the field. Normally these are just @getField@ +-- and @toField@ for some nested field. +-- +-- Unlike the straightforward chaining of 'getField'/'toField' methods, +-- @getFieldOpen@ does not require the immediate field to be dupable; rather, +-- in the best case only @res@ has to be dupable. +getFieldOpen + :: forall dt name res st. + (InstrGetFieldC dt name, HasDupableGetters dt) + => '[GetFieldType dt name] :-> '[res, GetFieldType dt name] + -> '[GetFieldType dt name] :-> '[res] + -> Label name + -> dt : st :-> res : dt ': st +getFieldOpen contWDup contWoDup = + I . instrGetFieldOpen @dt (iNonFailingCode contWDup) (iNonFailingCode contWoDup) + where + _needHasDupableGetters = Dict @(HasDupableGetters dt) + +-- | \"Open\" version of 'setField', an advanced method suitable for chaining +-- setters. +-- +-- It accepts a continuation accepting the field extracted for the update and +-- the new value that is being set. Normally this continuation is just @setField@ +-- for some nested field. +setFieldOpen + :: forall dt name new st. + InstrSetFieldC dt name + => '[new, GetFieldType dt name] :-> '[GetFieldType dt name] + -> Label name + -> (new ': dt ': st) :-> (dt ': st) +setFieldOpen cont = + I . instrSetFieldOpen @dt (iNonFailingCode cont) -- | Make up a datatype. You provide a pack of individual fields constructors. -- diff --git a/src/Lorentz/Address.hs b/src/Lorentz/Address.hs --- a/src/Lorentz/Address.hs +++ b/src/Lorentz/Address.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {- | @@ -60,9 +59,10 @@ import Lorentz.Annotation import Lorentz.Base import Lorentz.Constraints -import qualified Lorentz.Entrypoints.Core as Ep +import Lorentz.Entrypoints.Core qualified as Ep +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed (ContractRef(..), IsoValue(..)) -import qualified Morley.Michelson.Typed as M +import Morley.Michelson.Typed qualified as M import Morley.Michelson.Typed.Entrypoints (EpAddress(..)) import Morley.Tezos.Address (Address) import Morley.Util.Type @@ -79,6 +79,9 @@ deriving newtype (Eq, Ord, Buildable) deriving anyclass (IsoValue, HasAnnotation) +instance HasRPCRepr (TAddress cp vd) where + type AsRPC (TAddress cp vd) = TAddress cp vd + -- | For a contract and an address of its instance, construct a typed address. asAddressOf :: contract cp st vd -> Address -> TAddress cp vd asAddressOf _ = TAddress @@ -160,6 +163,9 @@ instance HasAnnotation (FutureContract a) where getAnnotation _ = M.starNotes + +instance HasRPCRepr (FutureContract p) where + type AsRPC (FutureContract p) = FutureContract p -- | Convert something to 'Address' in /Haskell/ world. -- diff --git a/src/Lorentz/Annotation.hs b/src/Lorentz/Annotation.hs --- a/src/Lorentz/Annotation.hs +++ b/src/Lorentz/Annotation.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE UndecidableSuperClasses #-} @@ -25,16 +24,16 @@ ) where import Data.Char (isUpper) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Manipulate (toCamel, toPascal, toSnake) -import qualified GHC.Generics as G +import GHC.Generics qualified as G import Morley.Michelson.Text import Morley.Michelson.Typed (BigMap, BigMapId, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, Ticket, ToT, insertTypeAnn, starNotes) import Morley.Michelson.Typed.Haskell.Value (GValueType) -import Morley.Michelson.Untyped (FieldAnn, TypeAnn, VarAnn, noAnn, unsafeMkAnnotation) +import Morley.Michelson.Untyped (FieldAnn, TypeAnn, VarAnn, mkAnnotation, noAnn) import Morley.Tezos.Address import Morley.Tezos.Core import Morley.Tezos.Crypto @@ -75,7 +74,7 @@ ---------------------------------------------------------------------------- ctorNameToAnnWithOptions :: forall ctor. (KnownSymbol ctor, HasCallStack) => AnnOptions -> FieldAnn -ctorNameToAnnWithOptions o = unsafeMkAnnotation . fieldAnnModifier o $ headToLower $ (symbolValT' @ctor) +ctorNameToAnnWithOptions o = unsafe . mkAnnotation . fieldAnnModifier o $ headToLower $ (symbolValT' @ctor) -- | Used in `GHasAnnotation` and `HasAnnotation` as a flag to track -- whether or not it directly follows an entrypoint to avoid introducing @@ -114,7 +113,7 @@ getAnnotation @a b where symbolAnn :: forall s. KnownSymbol s => TypeAnn - symbolAnn = unsafeMkAnnotation $ symbolValT' @s + symbolAnn = unsafe . mkAnnotation $ symbolValT' @s instance (HasAnnotation (Maybe a), KnownSymbol name) => HasAnnotation (NamedF Maybe a name) where diff --git a/src/Lorentz/Arith.hs b/src/Lorentz/Arith.hs --- a/src/Lorentz/Arith.hs +++ b/src/Lorentz/Arith.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Type families from "Morley.Michelson.Typed.Arith" lifted to Haskell types. module Lorentz.Arith @@ -11,13 +10,13 @@ , ToIntegerArithOpHs (..) ) where -import GHC.TypeLits hiding (Div) +import GHC.TypeLits (type (+)) import Prelude hiding (natVal) import Lorentz.Base import Lorentz.Value import Morley.Michelson.Typed.Arith -import qualified Morley.Michelson.Typed.Instr as M +import Morley.Michelson.Typed.Instr qualified as M -- | Lifted 'ArithOp'. class ArithOpHs (aop :: Type) (n :: Type) (m :: Type) (r :: Type) where @@ -134,7 +133,6 @@ instance (r ~ Integer) => ArithOpHs Sub Integer Integer r instance (r ~ Timestamp) => ArithOpHs Sub Timestamp Integer r instance (r ~ Integer) => ArithOpHs Sub Timestamp Timestamp r -instance (r ~ Mutez) => ArithOpHs Sub Mutez Mutez r instance (r ~ (Fixed p)) => ArithOpHs Sub (Fixed p) (Fixed p) r instance (r ~ (Fixed p)) => ArithOpHs Sub (Fixed p) Integer r diff --git a/src/Lorentz/Base.hs b/src/Lorentz/Base.hs --- a/src/Lorentz/Base.hs +++ b/src/Lorentz/Base.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -36,7 +35,7 @@ ) where import Data.Default (def) -import qualified Data.List.NonEmpty as NE (fromList) +import Data.List.NonEmpty qualified as NE (fromList) import Fmt (Buildable(..)) import Lorentz.Constraints @@ -51,8 +50,8 @@ import Morley.Michelson.Typed (Instr(..), IsoValue(..), Operation, RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr, rfMerge) -import qualified Morley.Michelson.Typed as M (Contract) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as M (Contract) +import Morley.Michelson.Untyped qualified as U -- | Alias for instruction which hides inner types representation via @T@. newtype (inp :: [Type]) :-> (out :: [Type]) = LorentzInstr @@ -126,7 +125,7 @@ data SomeContractCode where SomeContractCode - :: (NiceParameterFull cp, NiceStorage st) + :: (NiceParameter cp, NiceStorage st) => ContractCode cp st -> SomeContractCode @@ -138,7 +137,7 @@ -- Michelson. In Michelson, ability to call a view is fully checked at runtime, -- but in Lorentz we want to make calls safer at compile-time. data Contract cp st vd = - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) => + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) => Contract { -- | Ready contract code. cMichelsonContract :: M.Contract (ToT cp) (ToT st) diff --git a/src/Lorentz/Bytes.hs b/src/Lorentz/Bytes.hs --- a/src/Lorentz/Bytes.hs +++ b/src/Lorentz/Bytes.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE NoPolyKinds #-} @@ -35,16 +34,17 @@ import Crypto.Random (MonadRandom) import Fmt (Buildable(..)) import Morley.Util.Markdown -import qualified Type.Reflection as Refl +import Type.Reflection qualified as Refl import Lorentz.Annotation import Lorentz.Base import Lorentz.Constraints.Scopes import Lorentz.Doc import Lorentz.Value -import qualified Morley.Michelson.Typed as T +import Morley.AsRPC (HasRPCRepr(..)) +import Morley.Michelson.Typed qualified as T import Morley.Tezos.Crypto -import qualified Morley.Tezos.Crypto.Hash as Crypto +import Morley.Tezos.Crypto.Hash qualified as Crypto -- | Everything which is represented as bytes inside. class (KnownValue bs, ToT bs ~ ToT ByteString) => BytesLike bs where @@ -71,6 +71,9 @@ instance Buildable (Packed a) where build = build . toVal +instance HasRPCRepr (Packed a) where + type AsRPC (Packed a) = Packed a + instance TypeHasDoc a => TypeHasDoc (Packed a) where typeDocMdDescription = [md| Packed value of the given type. @@ -102,6 +105,9 @@ instance Buildable (TSignature a) where build = build . toVal +instance HasRPCRepr (TSignature a) where + type AsRPC (TSignature a) = TSignature a + instance TypeHasDoc a => TypeHasDoc (TSignature a) where typeDocMdDescription = "Signature for data of the given type." typeDocMdReference = poly1TypeDocMdReference @@ -134,6 +140,9 @@ instance Buildable (Hash alg a) where build = build . toVal +instance HasRPCRepr (Hash alg a) where + type AsRPC (Hash alg a) = Hash alg a + instance (KnownHashAlgorithm alg, TypeHasDoc a) => TypeHasDoc (Hash alg a) where typeDocMdDescription = [md| Hash of a value. @@ -242,6 +251,9 @@ deriving newtype (IsoValue, HasAnnotation) deriving stock Generic +instance HasRPCRepr (ChestT a) where + type AsRPC (ChestT a) = ChestT a + instance TypeHasDoc a => TypeHasDoc (ChestT a) where typeDocMdDescription = [md| Timelock puzzle chest containing a typed value. @@ -260,6 +272,9 @@ data OpenChestT a = ChestContentT a | ChestOpenFailedT Bool deriving stock (Generic, Show, Eq) deriving anyclass (T.IsoValue, HasAnnotation) + +instance HasRPCRepr a => HasRPCRepr (OpenChestT a) where + type AsRPC (OpenChestT a) = OpenChestT (AsRPC a) instance (TypeHasDoc a) => TypeHasDoc (OpenChestT a) where typeDocMdDescription = "Typed result of opening a typed timelocked chest." diff --git a/src/Lorentz/Coercions.hs b/src/Lorentz/Coercions.hs --- a/src/Lorentz/Coercions.hs +++ b/src/Lorentz/Coercions.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -35,9 +34,9 @@ , Wrappable ) where -import qualified Data.Coerce as Coerce +import Data.Coerce qualified as Coerce import Data.Constraint ((\\)) -import qualified GHC.Generics as G +import GHC.Generics qualified as G import Unsafe.Coerce (unsafeCoerce) import Lorentz.Address @@ -58,7 +57,7 @@ -- -- We discourage using this function on Lorentz types, consider using 'Data.Coerce.coerce' -- instead. --- One of the reasons forthat is that in Lorentz it's common to declare types as +-- One of the reasons for that is that in Lorentz it's common to declare types as -- newtypes consisting of existing primitives, and @forcedCoerce@ tends to ignore -- all phantom type variables of newtypes thus violating their invariants. forcedCoerce :: Coerce.Coercible a b => a -> b diff --git a/src/Lorentz/Common.hs b/src/Lorentz/Common.hs --- a/src/Lorentz/Common.hs +++ b/src/Lorentz/Common.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Common primitives. module Lorentz.Common diff --git a/src/Lorentz/Constraints/Derivative.hs b/src/Lorentz/Constraints/Derivative.hs --- a/src/Lorentz/Constraints/Derivative.hs +++ b/src/Lorentz/Constraints/Derivative.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Some derivative constraints. -- diff --git a/src/Lorentz/Constraints/Scopes.hs b/src/Lorentz/Constraints/Scopes.hs --- a/src/Lorentz/Constraints/Scopes.hs +++ b/src/Lorentz/Constraints/Scopes.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE UndecidableSuperClasses #-} @@ -18,6 +17,7 @@ , NiceParameter , NiceUntypedValue , NiceStorage + , NiceStorageFull , NiceUnpackedValue , NiceViewable , NiceNoBigMap @@ -67,17 +67,15 @@ class (HasNoNestedBigMaps (ToT a), IsoValue a) => CanHaveBigMap a instance (HasNoNestedBigMaps (ToT a), IsoValue a) => CanHaveBigMap a --- | Constraint applied to any part of parameter type. --- --- Note that you don't usually apply this constraint to the whole parameter, --- consider using t'Lorentz.Constraints.Derivative.NiceParameterFull' in such case. +-- | Constraint applied to any part of a parameter type. -- --- Using this type is justified e.g. when calling another contract, there --- you usually supply an entrypoint argument, not the whole parameter. +-- Use t'Lorentz.Constraints.Derivative.NiceParameterFull' instead +-- when you need to know the contract's entrypoints at compile-time. type NiceParameter a = (ProperParameterBetterErrors (ToT a), KnownValue a) -type NiceStorage a = - (ProperStorageBetterErrors (ToT a), HasAnnotation a, KnownValue a) +type NiceStorage a = (ProperStorageBetterErrors (ToT a), KnownValue a) + +type NiceStorageFull a = (NiceStorage a, HasAnnotation a) type NiceConstant a = (ProperConstantBetterErrors (ToT a), KnownValue a) diff --git a/src/Lorentz/ContractRegistry.hs b/src/Lorentz/ContractRegistry.hs --- a/src/Lorentz/ContractRegistry.hs +++ b/src/Lorentz/ContractRegistry.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module contains various datatypes and functions which are -- common for contract registry packages (e.g. @@ -22,13 +21,13 @@ ) where import Data.Aeson.Encode.Pretty (encodePretty, encodePrettyToTextBuilder) -import qualified Data.ByteString.Lazy.Char8 as BS (putStrLn) +import Data.ByteString.Lazy.Char8 qualified as BS (putStrLn) import Data.Constraint ((\\)) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Text.Lazy.Builder (toLazyText) -import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile) +import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile) import Fmt (Buildable(..), blockListF, nameF, pretty, (+|), (|+)) -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import Lorentz.Constraints import Lorentz.Doc @@ -38,7 +37,7 @@ import Morley.Michelson.Analyzer (analyze) import Morley.Michelson.Printer (printTypedContract) import Morley.Michelson.Typed (IsoValue(..), Notes) -import qualified Morley.Michelson.Typed as M +import Morley.Michelson.Typed qualified as M import Morley.Util.CLI (mkCommandParser) data ContractInfo = diff --git a/src/Lorentz/Default.hs b/src/Lorentz/Default.hs --- a/src/Lorentz/Default.hs +++ b/src/Lorentz/Default.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Default values for Lorentz. module Lorentz.Default ( LDefault (..) ) where -import qualified Prelude as P +import Prelude qualified as P import Lorentz.Base import Lorentz.Coercions @@ -42,8 +41,8 @@ -- it cannot be checked on emptiness instance (LDefault a, KnownSymbol n) => LDefault (NamedF P.Identity a n) where - ldef = P.fromLabel :! ldef - lIsDef = fromNamed P.fromLabel # lIsDef + ldef = P.fromLabel @n :! ldef + lIsDef = fromNamed (P.fromLabel @n) # lIsDef instance (LDefault a, LDefault b) => LDefault (a, b) where ldef = (ldef, ldef) diff --git a/src/Lorentz/Doc.hs b/src/Lorentz/Doc.hs --- a/src/Lorentz/Doc.hs +++ b/src/Lorentz/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -169,7 +168,7 @@ {-# DEPRECATED buildLorentzDocWithGitRev "Use `buildDoc . attachDocCommons gitRev` instead." -#-} + #-} buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc buildLorentzDocWithGitRev gitRev = buildDoc . attachDocCommons gitRev @@ -179,7 +178,7 @@ {-# DEPRECATED renderLorentzDocWithGitRev "Use `buildMarkdownDoc . attachDocCommons gitRev` instead." -#-} + #-} renderLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> LText renderLorentzDocWithGitRev gitRev = contractDocToMarkdown . buildLorentzDocWithGitRev gitRev diff --git a/src/Lorentz/Empty.hs b/src/Lorentz/Empty.hs --- a/src/Lorentz/Empty.hs +++ b/src/Lorentz/Empty.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -22,6 +21,7 @@ import Lorentz.Doc import Lorentz.Errors import Lorentz.Value +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed.Haskell.Doc -- | Replacement for uninhabited type. @@ -29,6 +29,9 @@ newtype Empty = Empty () deriving stock Generic deriving anyclass (IsoValue, HasAnnotation) + +instance HasRPCRepr Empty where + type AsRPC Empty = Empty instance TypeHasDoc Empty where typeDocMdDescription = diff --git a/src/Lorentz/Entrypoints/Core.hs b/src/Lorentz/Entrypoints/Core.hs --- a/src/Lorentz/Entrypoints/Core.hs +++ b/src/Lorentz/Entrypoints/Core.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE UndecidableSuperClasses #-} @@ -50,12 +49,12 @@ import Data.Typeable (typeRep) import Data.Vinyl (Rec(..)) import Fcf (Eval, Exp) -import qualified Fcf -import qualified Fcf.Utils as Fcf +import Fcf qualified +import Fcf.Utils qualified as Fcf import Fmt (pretty) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Util.Label import Morley.Util.Type import Morley.Util.TypeLits @@ -266,7 +265,7 @@ [ "Lorentz unexpectedly compiled into contract with \ \illegal parameter declaration.\n" , "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n" - , "Derived annotations: " <> show notes <> "\n" + , "Derived annotations: " <> pretty notes <> "\n" , "Failure reason: " <> pretty e ] diff --git a/src/Lorentz/Entrypoints/Doc.hs b/src/Lorentz/Entrypoints/Doc.hs --- a/src/Lorentz/Entrypoints/Doc.hs +++ b/src/Lorentz/Entrypoints/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -43,16 +42,18 @@ , RequireFlatEpDerivation ) where +import Debug qualified (show) + import Control.Lens.Cons (_head) import Data.Char (toLower) import Data.Constraint (Dict(..)) -import qualified Data.Map as Map -import qualified Data.Text as T +import Data.Map qualified as Map +import Data.Text qualified as T import Data.Vinyl.Core (RMap, rappend) import Fmt (Buildable(..), build, fmt, listF) import GHC.Generics ((:+:)) -import qualified GHC.Generics as G -import qualified Text.Show +import GHC.Generics qualified as G +import Text.Show qualified import Lorentz.ADT import Lorentz.Annotation @@ -65,10 +66,10 @@ import Morley.Michelson.Printer (printTypedValue) import Morley.Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB) import Morley.Michelson.Typed (EpName, ToT, mkUType, pattern DefEpName, sampleTypedValue, sing) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Haskell.Doc import Morley.Michelson.Typed.Haskell.Instr -import qualified Morley.Michelson.Untyped as Untyped +import Morley.Michelson.Untyped qualified as Untyped import Morley.Util.Label (Label) import Morley.Util.Markdown import Morley.Util.Type @@ -238,7 +239,7 @@ instance Show ParamBuilder where show (ParamBuilder pb) = -- Using @'x'@ symbol here because unicode does not render well in 'show' - "ParamBuilder " <> show (pb "x") + "ParamBuilder " <> Debug.show (pb "x") instance Eq ParamBuilder where (==) = (==) `on` pbSample @@ -331,7 +332,7 @@ , epaBuilding = [] } -mkDEpUType :: forall t. (KnownValue t, HasAnnotation t) => Untyped.Ty +mkDEpUType :: forall t. HasAnnotation t => Untyped.Ty mkDEpUType = mkUType (getAnnotation @t FollowEntrypoint) mkDEntrypointArgSimple diff --git a/src/Lorentz/Entrypoints/Helpers.hs b/src/Lorentz/Entrypoints/Helpers.hs --- a/src/Lorentz/Entrypoints/Helpers.hs +++ b/src/Lorentz/Entrypoints/Helpers.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Lorentz.Entrypoints.Helpers ( ctorNameToAnn @@ -10,15 +9,16 @@ , RequireSumType ) where +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed.Haskell import Morley.Michelson.Typed.T -import Morley.Michelson.Untyped (EpName, FieldAnn, epNameFromParamAnn, unsafeMkAnnotation) +import Morley.Michelson.Untyped (EpName, FieldAnn, epNameFromParamAnn, mkAnnotation) import Morley.Util.Text import Morley.Util.Type import Morley.Util.TypeLits ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn -ctorNameToAnn = unsafeMkAnnotation . headToLower $ (symbolValT' @ctor) +ctorNameToAnn = unsafe . mkAnnotation . headToLower $ (symbolValT' @ctor) ctorNameToEp :: forall ctor. (KnownSymbol ctor, HasCallStack) => EpName ctorNameToEp = @@ -35,6 +35,9 @@ deriving stock Generic deriving anyclass instance (WellTypedIsoValue r) => IsoValue (ShouldHaveEntrypoints r) + +instance HasRPCRepr a => HasRPCRepr (ShouldHaveEntrypoints a) where + type AsRPC (ShouldHaveEntrypoints a) = ShouldHaveEntrypoints (AsRPC a) -- | Used to understand whether a type can potentially declare any entrypoints. type family CanHaveEntrypoints (p :: Type) :: Bool where diff --git a/src/Lorentz/Entrypoints/Impl.hs b/src/Lorentz/Entrypoints/Impl.hs --- a/src/Lorentz/Entrypoints/Impl.hs +++ b/src/Lorentz/Entrypoints/Impl.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Common implementations of entrypoints. module Lorentz.Entrypoints.Impl @@ -22,14 +21,14 @@ import Data.Vinyl.Core (Rec(..), (<+>)) import Data.Vinyl.Recursive (rmap) import Fcf (Eval, Exp) -import qualified Fcf -import qualified GHC.Generics as G +import Fcf qualified +import GHC.Generics qualified as G import Morley.Util.TypeLits import Lorentz.Value import Morley.Michelson.Typed import Morley.Michelson.Typed.Haskell.Value (GValueType) -import Morley.Michelson.Untyped (FieldAnn, noAnn, unsafeMkAnnotation) +import Morley.Michelson.Untyped (FieldAnn, mkAnnotation, noAnn) import Morley.Util.Fcf (Over2, TyEqSing, type (<|>)) import Morley.Util.Type @@ -108,7 +107,7 @@ '[ Fcf.Is (TyEqSing r) ('Just cp) , Fcf.Else (PlainLookupEntrypointExt deriv cp) ] - epdNotes = (plainEpdNotesExt @deriv @cp, unsafeMkAnnotation (symbolValT' @r)) + epdNotes = (plainEpdNotesExt @deriv @cp, unsafe . mkAnnotation $ symbolValT' @r) epdCall label@(Label :: Label name) = case sing @r %== sing @name of STrue -> EpConstructed EplArgHere SFalse -> plainEpdCallExt @deriv @cp label diff --git a/src/Lorentz/Entrypoints/Manual.hs b/src/Lorentz/Entrypoints/Manual.hs --- a/src/Lorentz/Entrypoints/Manual.hs +++ b/src/Lorentz/Entrypoints/Manual.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Allows specifying entrypoints without declaring 'ParameterHasEntrypoints' -- instance. @@ -11,6 +10,7 @@ import Lorentz.Constraints import Lorentz.Entrypoints.Core import Lorentz.Wrappable +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed -- | Wrap parameter into this to locally assign a way to derive entrypoints for @@ -18,6 +18,9 @@ newtype ParameterWrapper (deriv :: Type) cp = ParameterWrapper { unParameterWraper :: cp } deriving stock Generic deriving anyclass (IsoValue, Unwrappable, Wrappable) + +instance HasRPCRepr cp => HasRPCRepr (ParameterWrapper deriv cp) where + type AsRPC (ParameterWrapper deriv cp) = ParameterWrapper deriv (AsRPC cp) -- Helper for implementing @instance ParameterHasEntrypoints ParameterWrapper@. data PwDeriv deriv diff --git a/src/Lorentz/Errors.hs b/src/Lorentz/Errors.hs --- a/src/Lorentz/Errors.hs +++ b/src/Lorentz/Errors.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE DeriveLift #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -50,12 +49,14 @@ , errorTagToMText ) where -import qualified Data.Char as C -import qualified Data.List as L +import Debug qualified (show) + +import Data.Char qualified as C +import Data.List qualified as L import Fmt (Buildable, build, fmt, pretty, (+|), (|+)) import Language.Haskell.TH.Syntax (Lift) import Text.Read (readsPrec) -import qualified Text.Show +import Text.Show qualified import Lorentz.Base import Lorentz.Doc @@ -69,6 +70,7 @@ import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Sing (castM, castSingE) import Morley.Util.Markdown +import Morley.Util.MismatchError import Morley.Util.Type import Morley.Util.TypeLits import Morley.Util.Typeable @@ -400,7 +402,7 @@ errorFromVal v = do let expectedTag = errorTagToMText (fromLabel @tag) - v' <- castM v \vType _ -> Left $ "Wrong type for custom error: " <> pretty vType + v' <- castM v \MkMismatchError{..} -> Left $ "Wrong type for custom error: " <> pretty meActual errArg <- verifyErrorTag @(CustomErrorRep tag) expectedTag $ fromVal @(CustomErrorRep tag) v' pure $ CustomError fromLabel errArg @@ -487,7 +489,7 @@ instance Eq (CustomErrorRep tag) => Eq (() -> CustomError tag) where e1 == e2 = e1 () == e2 () instance Show (CustomErrorRep tag) => Show (() -> CustomError tag) where - show e = show (e ()) + show e = Debug.show (e ()) -- | If 'CustomError' constructor is not provided its argument, we assume -- that this is unit-arg error and interpret the passed value as complete. @@ -506,7 +508,7 @@ errorToVal (mkCustomError ()) cont errorFromVal v = reifyTypeEquality @arg @() $ - errorFromVal v <&> \(CustomError l a) -> \b -> CustomError l (fst a, b) + errorFromVal v <&> \(CustomError l a) b -> CustomError l (fst a, b) instance (Typeable arg, ErrorHasDoc (CustomError tag)) => ErrorHasDoc (arg -> CustomError tag) where diff --git a/src/Lorentz/Errors/Common.hs b/src/Lorentz/Errors/Common.hs deleted file mode 100644 --- a/src/Lorentz/Errors/Common.hs +++ /dev/null @@ -1,32 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Some common errors. --- --- Such registry makes sense, as soon as errors are declared globally. -module Lorentz.Errors.Common () where - -import Fmt (Buildable(..)) - -import Lorentz.Errors - ----------------------------------------------------------------------------- --- Authorization ----------------------------------------------------------------------------- - --- | Contract initiator should be contract admin in order to perform this --- operation. -type instance ErrorArg "senderIsNotAdmin" = UnitErrorArg - -instance Buildable (CustomError "senderIsNotAdmin") where - build (CustomError _ (_, ())) = - "This operation can be executed only by admin, but is invoked by \ - \someone else" - -instance CustomErrorHasDoc "senderIsNotAdmin" where - customErrClass = ErrClassActionException - customErrDocMdCause = - "Entrypoint executed not by its administrator." diff --git a/src/Lorentz/Errors/Numeric/Contract.hs b/src/Lorentz/Errors/Numeric/Contract.hs --- a/src/Lorentz/Errors/Numeric/Contract.hs +++ b/src/Lorentz/Errors/Numeric/Contract.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | By default we represent error tags using strings. This module -- makes it possible to use numbers instead. It introduces new [error format]. @@ -31,9 +30,9 @@ ) where import Data.Bimap (Bimap) -import qualified Data.Bimap as Bimap +import Data.Bimap qualified as Bimap import Data.Default (def) -import qualified Data.HashSet as HS +import Data.HashSet qualified as HS import Data.Singletons (withSingI) import Fmt (pretty) @@ -93,7 +92,7 @@ deleteExistingR k m = case Bimap.lookupR k m of Just _ -> Bimap.deleteR k m Nothing -> - error $ "Tag " <> show k <> " does not appear in the contract" + error $ "Tag " <> pretty k <> " does not appear in the contract" -- | For each typical 'FAILWITH' that uses a string to represent error -- tag this function changes error tag to be a number using the @@ -136,22 +135,22 @@ applyErrorTagMapWithExcT errorTagMap exclusions instr = dfsModifyInstr dfsSettings step instr where - dfsSettings :: DfsSettings () + dfsSettings :: DfsSettings Identity dfsSettings = def { dsGoToValues = True } - tagToNatValue :: HasCallStack => MText -> SomeConstrainedValue ConstantScope + tagToNatValue :: HasCallStack => MText -> SomeConstant tagToNatValue tag = case (HS.member tag exclusions, Bimap.lookupR tag errorTagMap) of - (True, _) -> SomeConstrainedValue (VString tag) + (True, _) -> SomeConstant (VString tag) -- It will be applied to textual tags detected by 'modifyTypicalFailWith'. -- Here we assume that all of them are discovered by the analyzer. -- If this error ever happens, it means that someone used -- 'applyErrorTagMap' with incomplete 'ErrorTagMap' or there is an -- internal bug somewhere. (False, Nothing) -> error $ "Can't find a tag: " <> pretty tag - (False, Just n) -> SomeConstrainedValue (VNat n) + (False, Just n) -> SomeConstant (VNat n) step :: HasCallStack => Instr inp out -> Instr inp out step = modifyTypicalFailWith tagToNatValue diff --git a/src/Lorentz/Errors/Numeric/Doc.hs b/src/Lorentz/Errors/Numeric/Doc.hs --- a/src/Lorentz/Errors/Numeric/Doc.hs +++ b/src/Lorentz/Errors/Numeric/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Autodoc for numeric errors. module Lorentz.Errors.Numeric.Doc @@ -18,7 +17,7 @@ ) where import Control.Monad.Cont (callCC, runCont) -import qualified Data.Bimap as Bimap +import Data.Bimap qualified as Bimap import Data.Typeable (typeRep) import Fmt (build, pretty) import GHC.TypeNats (Nat) diff --git a/src/Lorentz/Expr.hs b/src/Lorentz/Expr.hs --- a/src/Lorentz/Expr.hs +++ b/src/Lorentz/Expr.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -309,9 +308,9 @@ -> ("amount" :! Expr s1 s2 Mutez) -> ("contract" :! Expr s2 s3 (ContractRef p)) -> Expr s0 s3 Operation -transferTokensE (N paramE) - (N amountE) - (N contractE) = +transferTokensE (arg #arg -> paramE) + (arg #amount -> amountE) + (arg #contract -> contractE) = paramE # dip (amountE # dip contractE) # transferTokens -- | Version of 'createContract' instruction that accepts @@ -333,10 +332,10 @@ -> ("storage" :! Expr s2 s3 st) -> ("contract" :! Contract p st vd) -> Expr s0 (TAddress p vd : s3) Operation -createContractE (N delegatorE) - (N balanceE) - (N storageE) - (N contract') = +createContractE (arg #delegate -> delegatorE) + (arg #balance -> balanceE) + (arg #storage -> storageE) + (arg #contract -> contract') = delegatorE # dip (balanceE # dip storageE) # createContract contract' -- | Version of 'view' instruction that accepts all the arguments as expressions. @@ -354,5 +353,5 @@ => ("arg" :! Expr s0 s1 arg) -> ("address" :! Expr s1 s2 (TAddress p vd)) -> Expr s0 s2 ret -viewE (N argE) (N addrE) = +viewE (arg #arg -> argE) (arg #address -> addrE) = argE # dip addrE # view @name diff --git a/src/Lorentz/Ext.hs b/src/Lorentz/Ext.hs --- a/src/Lorentz/Ext.hs +++ b/src/Lorentz/Ext.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -22,7 +21,7 @@ import Lorentz.Base import Morley.Michelson.Typed.Haskell import Morley.Michelson.Typed.Instr -import Morley.Util.Peano hiding (Nat) +import Morley.Util.Peano -- | Include a value at given position on stack into comment produced -- by 'printComment'. diff --git a/src/Lorentz/Extensible.hs b/src/Lorentz/Extensible.hs --- a/src/Lorentz/Extensible.hs +++ b/src/Lorentz/Extensible.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {- | This module contains implementation of 'Extensible' values. @@ -56,10 +55,10 @@ ) where import Data.Char (isSpace) -import qualified Data.Text as T -import Fmt (Buildable(build), (+||), (|+), (||+)) +import Data.Text qualified as T +import Fmt (Buildable(build), (+|), (|+)) import GHC.Generics ((:+:)(..)) -import qualified GHC.Generics as G +import GHC.Generics qualified as G import GHC.TypeLits (Nat) import GHC.TypeNats (type (+)) @@ -70,6 +69,7 @@ import Lorentz.Doc import Lorentz.Instr import Lorentz.Pack +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed import Morley.Util.Label (Label) import Morley.Util.Markdown @@ -80,6 +80,9 @@ deriving stock (Generic, Eq, Show) deriving anyclass (IsoValue, HasAnnotation, Unwrappable) +instance HasRPCRepr (Extensible x) where + type AsRPC (Extensible x) = Extensible x + type ExtVal x = (Generic x, GExtVal x (G.Rep x)) type GetCtors x = GGetCtors (G.Rep x) @@ -132,7 +135,7 @@ \case ConstructorIndexNotFound idx -> "Could not convert Extensible value into its Haskell representation: \ - \constructor #" +|| idx ||+ " was not found in the sum type \ + \constructor #" +| idx |+ " was not found in the sum type \ \constructors list" ArgumentUnpackFailed -> "Could not convert Extensible value into its Haskell representation: \ diff --git a/src/Lorentz/FixedArith.hs b/src/Lorentz/FixedArith.hs --- a/src/Lorentz/FixedArith.hs +++ b/src/Lorentz/FixedArith.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE InstanceSigs #-} -- This option was enabled, because of @@ -18,10 +17,9 @@ ) where -import Data.Fixed -import qualified GHC.TypeLits as Lit +import GHC.TypeLits qualified as Lit import Prelude hiding (and, compare, drop, natVal, some, swap) -import qualified Prelude as P +import Prelude qualified as P import Lorentz.Arith import Lorentz.Base @@ -34,6 +32,7 @@ import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Scope +{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-} -- | Class that enables support of rounding operations for Lorentz non-integer values -- Note: Round is implemented using "banker's rounding" strategy, rounding half-way values diff --git a/src/Lorentz/Instr.hs b/src/Lorentz/Instr.hs --- a/src/Lorentz/Instr.hs +++ b/src/Lorentz/Instr.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -73,6 +72,7 @@ , concat , concat' , slice, isNat, add, sub, rsub, mul, ediv, abs + , subMutez, rsubMutez , neg , lsl , lsr @@ -136,7 +136,7 @@ (EQ, GT, LT, abs, and, compare, concat, drop, get, map, not, or, some, swap, xor) import Data.Constraint ((\\)) -import qualified GHC.TypeNats as GHC (Nat) +import GHC.TypeNats (Nat) import Lorentz.Address import Lorentz.Arith @@ -169,10 +169,10 @@ -- | Drop top @n@ elements from the stack. dropN :: - forall (n :: GHC.Nat) (s :: [Type]). + forall (n :: Nat) (s :: [Type]). -- Note: if we introduce `nPeano ~ ToPeano n` variable, -- GHC will complain that this constraint is redundant. - ( SingI (ToPeano n) + ( SingIPeano n , RequireLongerOrSameLength (ToTs s) (ToPeano n) -- ↓ Kinda obvious, but not to GHC. , Drop (ToPeano n) (ToTs s) ~ ToTs (Drop (ToPeano n) s) @@ -215,7 +215,7 @@ dupNPeano = (I $ DUPN $ toPeanoNatural @n) \\ dupableEvi @a dupN :: - forall (n :: GHC.Nat) a inp out. + forall (n :: Nat) a inp out. ( ConstraintDUPNLorentz (ToPeano n) inp out a, Dupable a ) => inp :-> out dupN = dupNPeano @(ToPeano n) where @@ -249,7 +249,7 @@ digPeano = I $ DIG $ toPeanoNatural @n dig :: - forall (n :: GHC.Nat) inp out a. + forall (n :: Nat) inp out a. ( ConstraintDIGLorentz (ToPeano n) inp out a ) => inp :-> out dig = digPeano @(ToPeano n) @@ -268,7 +268,7 @@ dugPeano = I $ DUG $ toPeanoNatural @n dug :: - forall (n :: GHC.Nat) inp out a. + forall (n :: Nat) inp out a. ( ConstraintDUGLorentz (ToPeano n) inp out a ) => inp :-> out dug = dugPeano @(ToPeano n) @@ -358,10 +358,10 @@ => GetOpKeyHs c : c : s :-> Maybe (GetOpValHs c) : s get = I GET -type ConstraintPairGetLorentz (n :: GHC.Nat) (pair :: Type) = +type ConstraintPairGetLorentz (n :: Nat) (pair :: Type) = ( ConstraintGetN (ToPeano n) (ToT pair) , ToT (PairGetHs (ToPeano n) pair) ~ GetN (ToPeano n) (ToT pair) - , SingI (ToPeano n) + , SingIPeano n ) type family PairGetHs (ix :: Peano) (pair :: Type) :: Type where @@ -370,7 +370,7 @@ PairGetHs ('S ('S n)) (_, right) = PairGetHs n right pairGet - :: forall (n :: GHC.Nat) (pair :: Type) (s :: [Type]). + :: forall (n :: Nat) (pair :: Type) (s :: [Type]). ConstraintPairGetLorentz n pair => pair : s :-> PairGetHs (ToPeano n) pair : s pairGet = I $ GETN $ toPeanoNatural' @n @@ -386,10 +386,10 @@ => UpdOpKeyHs c : UpdOpParamsHs c : c : s :-> Maybe (GetOpValHs c) : c : s getAndUpdate = I GET_AND_UPDATE -type ConstraintPairUpdateLorentz (n :: GHC.Nat) (val :: Type) (pair :: Type) = +type ConstraintPairUpdateLorentz (n :: Nat) (val :: Type) (pair :: Type) = ( ConstraintUpdateN (ToPeano n) (ToT pair) , ToT (PairUpdateHs (ToPeano n) val pair) ~ UpdateN (ToPeano n) (ToT val) (ToT pair) - , SingI (ToPeano n) + , SingIPeano n ) type family PairUpdateHs (ix :: Peano) (val :: Type) (pair :: Type) :: Type where @@ -398,7 +398,7 @@ PairUpdateHs ('S ('S n)) val (left, right) = (left, PairUpdateHs n val right) pairUpdate - :: forall (n :: GHC.Nat) (val :: Type) (pair :: Type) (s :: [Type]). + :: forall (n :: Nat) (val :: Type) (pair :: Type) (s :: [Type]). (ConstraintPairUpdateLorentz n val pair) => val : pair : s :-> PairUpdateHs (ToPeano n) val pair : s pairUpdate = I $ UPDATEN $ toPeanoNatural' @n @@ -484,7 +484,7 @@ dipNPeano (iNonFailingCode -> a) = I (DIPN (toPeanoNatural @n) a) dipN :: - forall (n :: GHC.Nat) (inp :: [Type]) (out :: [Type]) (s :: [Type]) (s' :: [Type]). + forall (n :: Nat) (inp :: [Type]) (out :: [Type]) (s :: [Type]) (s' :: [Type]). ( ConstraintDIPNLorentz (ToPeano n) inp out s s' ) => s :-> s' -> inp :-> out dipN = dipNPeano @(ToPeano n) @@ -549,6 +549,12 @@ :: ArithOpHs Sub n m r => m : n : s :-> r : s rsub = swap # sub + +subMutez :: Mutez : Mutez : s :-> Maybe Mutez : s +subMutez = I SUB_MUTEZ + +rsubMutez :: Mutez : Mutez : s :-> Maybe Mutez : s +rsubMutez = swap # subMutez mul :: ArithOpHs Mul n m r diff --git a/src/Lorentz/Iso.hs b/src/Lorentz/Iso.hs --- a/src/Lorentz/Iso.hs +++ b/src/Lorentz/Iso.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Isomorphisms in Lorentz. module Lorentz.Iso diff --git a/src/Lorentz/Layouts.hs b/src/Lorentz/Layouts.hs new file mode 100644 --- /dev/null +++ b/src/Lorentz/Layouts.hs @@ -0,0 +1,10 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Various Michelson layouts for datatypes. +module Lorentz.Layouts + ( module Exports + ) where + +import Lorentz.Layouts.NonDupable as Exports +import Morley.Michelson.Typed.Haskell.Compatibility as Exports diff --git a/src/Lorentz/Layouts/NonDupable.hs b/src/Lorentz/Layouts/NonDupable.hs new file mode 100644 --- /dev/null +++ b/src/Lorentz/Layouts/NonDupable.hs @@ -0,0 +1,62 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Product type Michelson layout optimized for non-dupable fields case. +module Lorentz.Layouts.NonDupable + ( deriveSemiDupableGeneric + ) where + +import Language.Haskell.TH qualified as TH + +import Lorentz.ADT (HasDupableGetters) +import Morley.Util.CustomGeneric +import Morley.Util.TH + +-- | Produce 'Generic' instance for a datatype containing non-dupable and +-- plain dupable elements so that operations on this datatype +-- (like @getField@) remain optimal in average. +-- +-- Derivation strategies available for 'customGeneric' suffer from a problem: +-- @getField@ is non-optimal as long as during its recursive descend it +-- operates with a non-dupable pairs subtree. 'deriveSemiDupableGeneric' +-- tries to keep all dupable elements in the left subtree of the root +-- (speeding up @getField@ on them), and all non-dupable elements in the right +-- subtree. +-- +-- Prerequisites for calling this function: +-- +-- 1. All the fields of dupable types must locate before all the fields of +-- non-dupable types. +-- 2. You have to supply the expected number of /non-dupable/ fields as an +-- argument. +-- We expect this number, not the number of dupable fields, since +-- non-dupable elements are rare and so are supposed to be updated +-- less often. +-- +-- Unfortunatelly, there seems to be no decent way to see whether a type is +-- dupable or not at TH time, so we have to accept some information explicitly. +-- To ensure that this information is up to date, each time calling this +-- function __we encourage the user to also add a test__ using utilities from +-- "Lorentz.Test.DupableScan" module. +deriveSemiDupableGeneric :: String -> Int -> TH.DecsQ +deriveSemiDupableGeneric tyCtor nonDupableFieldsNum = fmap concat $ sequence + [ customGeneric tyCtor (semiDupableGenericStrategy nonDupableFieldsNum) + , [d| instance HasDupableGetters $(addTypeVariables =<< lookupTypeNameOrFail tyCtor) |] + ] + +-- | Given number of non-dupable field (that must be last fields in the +-- datatype), produces a strategy that puts dupable fields at the left pair +-- subtree and non-dupable fields at the right pair subtree. +semiDupableGenericStrategy :: Int -> GenericStrategy +semiDupableGenericStrategy nonDupableFieldsNum = + (fromDepthsStrategy' + makeRightBalDepths -- ← doesn't matter, we expect exactly 1 constructor + (\n -> makeSplittedDepths makeRightBalDepths (n - nonDupableFieldsNum) n)) + +-- | Depths distribution generator to be passed to 'fromDepthsStrategy', +-- it splits entries into two large groups and applies another depths +-- generator to each group. +makeSplittedDepths :: (Int -> [Natural]) -> Int -> (Int -> [Natural]) +makeSplittedDepths mkInnerDepths leftN n + | leftN == 0 || leftN == n = mkInnerDepths n + | otherwise = fmap succ $ mkInnerDepths leftN ++ mkInnerDepths (n - leftN) diff --git a/src/Lorentz/Macro.hs b/src/Lorentz/Macro.hs --- a/src/Lorentz/Macro.hs +++ b/src/Lorentz/Macro.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE NoStarIsType #-} @@ -135,9 +134,8 @@ import Data.Constraint ((\\)) import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+)) import Fmt.Internal.Tuple (TupleF) -import qualified GHC.TypeLits as Lit -import GHC.TypeNats (type (*), type (+), type (-)) -import qualified GHC.TypeNats as GHC (Nat) +import GHC.TypeLits qualified as Lit +import GHC.TypeNats (Nat, type (*), type (+), type (-)) import Lorentz.ADT import Lorentz.Annotation @@ -152,6 +150,7 @@ import Lorentz.Polymorphic import Lorentz.Value import Lorentz.ViewBase +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed (ConstraintDIPN', ConstraintDUG', T, viewNameToMText) import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Haskell.Value @@ -162,7 +161,8 @@ import Morley.Util.TypeLits -- $setup --- >>> :m +Lorentz.Run.Simple Lorentz.Instr +-- >>> :m +Lorentz.Base Lorentz.Run.Simple Lorentz.Instr +-- >>> import Prelude hiding (drop, not, compare, swap) ---------------------------------------------------------------------------- -- Compare @@ -335,10 +335,10 @@ -- | Custom Lorentz macro that drops element with given index -- (starting from 0) from the stack. dropX - :: forall (n :: GHC.Nat) a inp out s s'. + :: forall (n :: Nat) a inp out s s'. ( ConstraintDIPNLorentz (ToPeano n) inp out s s' , s ~ (a ': s') - , SingI (ToPeano n) + , SingIPeano n ) => inp :-> out dropX = dipN @n @inp @out @s @s' drop @@ -359,7 +359,7 @@ -- -- For example, `cloneX @3` has type `a : s :-> a : a : a : a : s`. cloneX - :: forall (n :: GHC.Nat) a s. CloneX (ToPeano n) a s + :: forall (n :: Nat) a s. CloneX (ToPeano n) a s => a : s :-> a : CloneXT (ToPeano n) a s cloneX = cloneXImpl @(ToPeano n) @@ -371,7 +371,7 @@ -- -- > duupX = dupN @n duupX - :: forall (n :: GHC.Nat) a s s'. + :: forall (n :: Nat) a s s'. (ConstraintDUPNLorentz (ToPeano n) s s' a, Dupable a) => s :-> a ': s duupX = dupN @n @@ -381,6 +381,31 @@ -- -- You can treat this macro as calling a Michelson function with given number -- of arguments. +-- +-- Given a stack of 3 elements, +-- >>> arg = (1 :: Integer, (2 :: Integer, 3 :: Integer)) +-- +-- @framedN@ will have access to exactly the number of elements specified, +-- >>> framedN @1 drop -$ arg +-- (2,3) +-- >>> framedN @1 (drop # drop) -$ arg +-- ... +-- ... error: +-- ... Couldn't match type ‘'[]’ with ‘Integer : o'0’ +-- ... +-- +-- When the number of elements is larger than the size of the stack, @framedN@ +-- will have access to all of them: +-- >>> framedN @5 (drop # drop) -$ arg +-- 3 +-- +-- But not more than there are on stack: +-- >>> framedN @5 (drop # drop # drop # drop) -$ arg +-- ... +-- ... error: +-- ... Couldn't match type ‘Integer’ with ‘(a0, (a1, out))’ +-- ... + framedN :: forall n nNat s i i' o o'. ( nNat ~ ToPeano n @@ -397,7 +422,7 @@ _example = framedN @2 carN - :: forall (n :: GHC.Nat) (pair :: Type) (s :: [Type]). + :: forall (n :: Nat) (pair :: Type) (s :: [Type]). ConstraintPairGetLorentz (2 * n + 1) pair => pair : s :-> PairGetHs (ToPeano (2 * n + 1)) pair : s carN = pairGet @(2 * n + 1) @@ -409,7 +434,7 @@ _example' = carN @1 cdrN - :: forall (n :: GHC.Nat) (pair :: Type) (s :: [Type]). + :: forall (n :: Nat) (pair :: Type) (s :: [Type]). ConstraintPairGetLorentz (2 * n) pair => pair : s :-> PairGetHs (ToPeano (2 * n)) pair : s cdrN = pairGet @(2 * n) @@ -423,56 +448,166 @@ _example'' :: '[ (String, (Integer, ())) ] :-> '[ () ] _example'' = cdrN @2 +-- | +-- >>> papair == pair # pair +-- True +-- +-- >>> papair -$ (True, (1, ())) +-- ((True,1),()) papair :: a : b : c : s :-> ((a, b), c) : s papair = pair # pair +-- | +-- >>> ppaiir == dip pair # pair +-- True +-- +-- >>> ppaiir -$ (True, (1, ())) +-- (True,(1,())) ppaiir :: a : b : c : s :-> (a, (b, c)) : s ppaiir = dip pair # pair +-- | +-- >>> cdar == cdr # car +-- True +-- +-- >>> cdar -$ (True, (1, ())) +-- 1 cdar :: (a1, (a2, b)) : s :-> a2 : s cdar = cdr # car +-- | +-- >>> cddr == cdr # cdr +-- True +-- +-- >>> cddr -$ (True, (1, ())) +-- () cddr :: (a1, (a2, b)) : s :-> b : s cddr = cdr # cdr +-- | +-- >>> caar == car # car +-- True +-- +-- >>> caar -$ ((True, 1), ()) +-- True caar :: ((a, b1), b2) : s :-> a : s caar = car # car +-- | +-- >>> cadr == car # cdr +-- True +-- +-- >>> cadr -$ ((True, 1), ()) +-- 1 cadr :: ((a, b1), b2) : s :-> b1 : s cadr = car # cdr +-- | +-- >>> setCar == cdr # swap # pair +-- True +-- +-- >>> setCar -$ ((True, 1), ()) +-- ((),1) setCar :: (a, b1) : (b2 : s) :-> (b2, b1) : s setCar = cdr # swap # pair +-- | +-- >>> setCdr == car # pair +-- True +-- +-- >>> setCdr -$ ((True, 1), ()) +-- (True,()) setCdr :: (a, b1) : (b2 : s) :-> (a, b2) : s setCdr = car # pair +-- | +-- >>> mapCar (not @Bool) == unpair # (not @Bool) # pair +-- True +-- +-- >>> mapCar not -$ (True, 1) +-- (False,1) mapCar :: (forall s0. a : s0 :-> a1 : s0) -> (a, b) : s :-> (a1, b) : s mapCar op = unpair # op # pair +-- | +-- >>> mapCdr (not @Bool) == unpair # dip (not @Bool) # pair +-- True +-- +-- >>> mapCdr not -$ (1, True) +-- (1,False) mapCdr :: (forall s0. b : s0 :-> b1 : s0) -> (a, b) : s :-> (a, b1) : s mapCdr op = unpair # dip op # pair +-- | +-- >>> ifRight (not @Bool) (dup @Integer # compare # eq0) == ifLeft (dup @Integer # compare # eq0) (not @Bool) +-- True +-- +-- >>> ifRight not (dup # compare # eq0) -$ (Right True :: Either Integer Bool) +-- False +-- +-- >>> ifRight not (dup # compare # eq0) -$ (Left 1 :: Either Integer Bool) +-- True ifRight :: (b : s :-> s') -> (a : s :-> s') -> (Either a b : s :-> s') ifRight l r = ifLeft r l + +-- | +-- >>> ifSome (dup @Integer # compare # eq0) (push False) == ifNone (push False) (dup @Integer # compare # eq0) +-- True +-- +-- >>> ifSome (dup # compare # eq0) (push False) -$ (Just 1 :: Maybe Integer) +-- True +-- +-- >>> ifSome (dup # compare # eq0) (push False) -$ (Nothing :: Maybe Integer) +-- False ifSome :: (a : s :-> s') -> (s :-> s') -> (Maybe a : s :-> s') ifSome s n = ifNone n s + +-- | +-- >>> when_ (push 5 # add @Integer @Integer) == if_ (push 5 # add @Integer @Integer) nop +-- True +-- +-- >>> when_ (push 5 # add @Integer) -$ (True, 3) +-- 8 +-- +-- >>> when_ (push 5 # add @Integer) -$ (False, 3) +-- 3 when_ :: (s :-> s) -> (Bool : s :-> s) when_ i = if_ i nop +-- | +-- >>> unless_ (push 5 # add @Integer @Integer) == if_ nop (push 5 # add @Integer @Integer) +-- True +-- +-- >>> unless_ (push 5 # add @Integer) -$ (True, 3) +-- 3 +-- +-- >>> unless_ (push 5 # add @Integer) -$ (False, 3) +-- 8 unless_ :: (s :-> s) -> (Bool : s :-> s) unless_ i = if_ nop i +-- | +-- >>> whenSome drop == ifSome drop nop +-- True +-- +-- >>> whenSome drop -$ (Just 1 :: Maybe Integer, ()) +-- () whenSome :: (a : s :-> s) -> (Maybe a : s :-> s) whenSome i = ifSome i nop +-- | +-- >>> whenNone (push True) == ifNone (push True) nop +-- True +-- +-- >>> whenNone (push 1) -$ (Nothing :: Maybe Integer) +-- 1 whenNone :: (s :-> a : s) -> (Maybe a : s :-> a : s) whenNone i = ifNone i nop @@ -568,7 +703,7 @@ -- like this). -- In all other cases `replaceN @n` will drop the nth element (`dipN @n drop`) -- and then put the 0th one in its place (`dug @(n-1)`). -replaceN :: forall (n :: GHC.Nat) a (s :: [Type]) (s1 :: [Type]) (tail :: [Type]). +replaceN :: forall (n :: Nat) a (s :: [Type]) (s1 :: [Type]) (tail :: [Type]). ( ConstraintReplaceNLorentz (ToPeano (n - 1)) s a s1 tail , ReplaceN (ToPeano n) s a s1 tail ) @@ -625,7 +760,7 @@ -- In all other cases @updateN \@n instr@ will put the topmost element right above -- the nth one (@dug \@(n-1)@) and then apply the function to them in place -- (@dipN \@(n-1) instr@). -updateN :: forall (n :: GHC.Nat) a b (s :: [Type]) (mid :: [Type]) (tail :: [Type]). +updateN :: forall (n :: Nat) a b (s :: [Type]) (mid :: [Type]) (tail :: [Type]). ( ConstraintUpdateNLorentz (ToPeano (n - 1)) s a b mid tail , UpdateN (ToPeano n) s a b mid tail ) @@ -653,6 +788,9 @@ instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (View_ a1 r1) (View_ a2 r2) +instance HasRPCRepr a => HasRPCRepr (View_ a r) where + type AsRPC (View_ a r) = View_ (AsRPC a) r + instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View_ a r) where typeDocName _ = "View" typeDocMdDescription = @@ -718,6 +856,9 @@ deriving anyclass instance (WellTypedIsoValue r, WellTypedIsoValue a) => IsoValue (Void_ a r) instance (CanCastTo a1 a2, CanCastTo r1 r2) => CanCastTo (Void_ a1 r1) (Void_ a2 r2) + +instance HasRPCRepr a => HasRPCRepr (Void_ a r) where + type AsRPC (Void_ a r) = Void_ (AsRPC a) r instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (Void_ a r) where typeDocName _ = "Void" diff --git a/src/Lorentz/OpSize.hs b/src/Lorentz/OpSize.hs --- a/src/Lorentz/OpSize.hs +++ b/src/Lorentz/OpSize.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Operation size evaluation. module Lorentz.OpSize @@ -18,7 +17,7 @@ import Lorentz.Run import Lorentz.Value import Morley.Michelson.Typed (OpSize) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T -- | Estimate code operation size. contractOpSize :: Contract cp st vd -> OpSize diff --git a/src/Lorentz/Pack.hs b/src/Lorentz/Pack.hs --- a/src/Lorentz/Pack.hs +++ b/src/Lorentz/Pack.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Packing utilities. module Lorentz.Pack @@ -13,7 +12,7 @@ , expressionToScriptExpr ) where -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Constraint ((\\)) import Lorentz.Bytes diff --git a/src/Lorentz/Polymorphic.hs b/src/Lorentz/Polymorphic.hs --- a/src/Lorentz/Polymorphic.hs +++ b/src/Lorentz/Polymorphic.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Type families from "Morley.Michelson.Typed.Polymorphic" lifted to Haskell types. module Lorentz.Polymorphic @@ -60,6 +59,10 @@ instance MapOpHs [e] where type MapOpInpHs [e] = e type MapOpResHs [e] = [] + +instance MapOpHs (Maybe e) where + type MapOpInpHs (Maybe e) = e + type MapOpResHs (Maybe e) = Maybe -- | Lifted 'IterOp'. class ( IterOp (ToT c) diff --git a/src/Lorentz/Prelude.hs b/src/Lorentz/Prelude.hs --- a/src/Lorentz/Prelude.hs +++ b/src/Lorentz/Prelude.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Commonly used parts of regular Prelude. module Lorentz.Prelude diff --git a/src/Lorentz/Print.hs b/src/Lorentz/Print.hs --- a/src/Lorentz/Print.hs +++ b/src/Lorentz/Print.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-redundant-constraints #-} diff --git a/src/Lorentz/Rebinded.hs b/src/Lorentz/Rebinded.hs --- a/src/Lorentz/Rebinded.hs +++ b/src/Lorentz/Rebinded.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {- | Reimplementation of some syntax sugar. diff --git a/src/Lorentz/Referenced.hs b/src/Lorentz/Referenced.hs --- a/src/Lorentz/Referenced.hs +++ b/src/Lorentz/Referenced.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE FunctionalDependencies #-} diff --git a/src/Lorentz/ReferencedByName.hs b/src/Lorentz/ReferencedByName.hs --- a/src/Lorentz/ReferencedByName.hs +++ b/src/Lorentz/ReferencedByName.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE FunctionalDependencies #-} @@ -119,7 +118,7 @@ data VarPosition (s :: [Type]) (name :: Symbol) (var :: Type) where VarPosition :: (ConstraintVarPosition s n) - => (Sing (n :: Nat)) + => Sing (n :: Peano) -> VarPosition s name var instance ( TypeError (StackElemNotFound name) @@ -166,7 +165,7 @@ unsafeDupL :: forall n s var. (ConstraintVarPosition s n, Dupable var) - => Sing (n :: Nat) -> s :-> var : s + => Sing (n :: Peano) -> s :-> var : s unsafeDupL _ = dupNPeano @n \\ unsafeProvideConstraint @(Take (Decrement n) s ++ (var : Drop n s) ~ s) diff --git a/src/Lorentz/Run.hs b/src/Lorentz/Run.hs --- a/src/Lorentz/Run.hs +++ b/src/Lorentz/Run.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {- | Lorentz contracts compilation. @@ -60,8 +59,8 @@ import Data.Constraint ((\\)) import Data.Default (def) import Data.Vinyl.Core (Rec(..)) -import qualified Data.Vinyl.Functor as Rec -import qualified Data.Vinyl.Recursive as Rec +import Data.Vinyl.Functor qualified as Rec +import Data.Vinyl.Recursive qualified as Rec import Fmt ((+|), (|+)) import Lorentz.Annotation @@ -76,9 +75,11 @@ import Morley.Michelson.Interpret import Morley.Michelson.Optimizer (OptimizerConf, optimizeWithConf) import Morley.Michelson.Text (MText) -import Morley.Michelson.Typed (Instr(..), IsoValue, IsoValuesStack(..), ToTs, starParamNotes) -import qualified Morley.Michelson.Typed as M -import qualified Morley.Michelson.Untyped as U (canonicalEntriesOrder) +import Morley.Michelson.TypeCheck (typeCheckingWith, typeVerifyContract, typeVerifyView) +import Morley.Michelson.Typed + (Instr(..), IsoValue, IsoValuesStack(..), ToT, ToTs, convertContract, convertView, starParamNotes) +import Morley.Michelson.Typed qualified as M +import Morley.Michelson.Untyped qualified as U (canonicalEntriesOrder) import Morley.Util.Lens import Morley.Util.TypeLits import Morley.Util.TypeTuple @@ -133,7 +134,7 @@ -- -- This is an alias for 'mkContract'. defaultContract - :: (NiceParameterFull cp, NiceStorage st) + :: (NiceParameterFull cp, NiceStorageFull st) => ContractCode cp st -> Contract cp st () defaultContract code = compileLorentzContract $ ContractData code mempty defaultCompilationOptions @@ -143,13 +144,13 @@ -- Note that this accepts code with initial and final stacks unpaired for -- simplicity. mkContract - :: (NiceParameterFull cp, NiceStorage st) + :: (NiceParameterFull cp, NiceStorageFull st) => ContractCode cp st -> Contract cp st () mkContract = mkContractWith defaultCompilationOptions -- | Version of 'mkContract' that accepts custom compilation options. mkContractWith - :: (NiceParameterFull cp, NiceStorage st) + :: (NiceParameterFull cp, NiceStorageFull st) => CompilationOptions -> ContractCode cp st -> Contract cp st () mkContractWith opts code = compileLorentzContract $ ContractData code mempty opts @@ -164,7 +165,7 @@ -- -- Raw 'ContractCode' should not be used for distribution of contracts. data ContractData cp st vd = - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) => + (NiceParameterFull cp, NiceStorageFull st, NiceViewsDescriptor vd) => ContractData { cdCode :: ContractCode cp st -- ^ The contract itself. @@ -203,7 +204,7 @@ -- | Compile contract with 'defaultCompilationOptions'. defaultContractData - :: forall cp st. (NiceParameterFull cp, NiceStorage st) + :: forall cp st. (NiceParameterFull cp, NiceStorageFull st) => ContractCode cp st -> ContractData cp st () defaultContractData code = ContractData { cdCode = code @@ -221,16 +222,20 @@ :: forall cp st vd. ContractData cp st vd -> Contract cp st vd compileLorentzContract ContractData{..} = Contract{..} where - cMichelsonContract = M.Contract - { cCode = - let - maybeAddInitialCast = - if (cpNotes == starParamNotes || coDisableInitialCast cdCompilationOptions) - then id else (I CAST #) - in compileLorentzWithOptions cdCompilationOptions $ - maybeAddInitialCast cdCode - -- TODO [#997]: make ^^^ saner, as well as 'compileLorentzView' - + verify = typeVerifyContract @(ToT cp) @(ToT st) (convertContract cMichelsonContractRaw) + cMichelsonContract + | cpNotes == starParamNotes || coDisableInitialCast cdCompilationOptions + -- If contract parameter type has no annotations or explicitly asked, we drop CAST. + = cMichelsonContractRaw + | Right{} <- typeCheckingWith def verify = cMichelsonContractRaw + -- Check if the contract typechecks + | otherwise + -- Perform CAST if it doesn't + = cMichelsonContractRaw + { M.cCode = compileLorentzWithOptions + cdCompilationOptions (I CAST # cdCode :: ContractCode cp st) } + cMichelsonContractRaw = M.Contract + { cCode = compileLorentzWithOptions cdCompilationOptions cdCode , cParamNotes = cpNotes , cStoreNotes = getAnnotation @st NotFollowEntrypoint , cEntriesOrder = U.canonicalEntriesOrder @@ -275,22 +280,25 @@ -> M.SomeView (M.ToT st) compileLorentzView co (ContractView viewCode) | (_ :: Proxy ('ViewTyInfo name arg ret)) <- Proxy @vt = - let argNotes = getAnnotation @arg NotFollowEntrypoint in - let retNotes = getAnnotation @ret NotFollowEntrypoint in - M.SomeView M.View - { M.vName = demoteViewName @name - , M.vArgument = argNotes - , M.vReturn = retNotes - , M.vCode = - let - maybeAddInitialCast = - if (argNotes == M.starNotes || coDisableInitialCast co) - then id else (I CAST #) - in compileLorentzWithOptions co $ - maybeAddInitialCast viewCode - } - \\ niceViewableEvi @arg - \\ niceViewableEvi @ret + let argNotes = getAnnotation @arg NotFollowEntrypoint + retNotes = getAnnotation @ret NotFollowEntrypoint + stNotes = getAnnotation @ret NotFollowEntrypoint + verify = typeVerifyView @(ToT arg) @(ToT st) @(ToT ret) stNotes (convertView viewRaw) + viewRaw, viewWithNecessaryCast :: M.View (ToT arg) (ToT st) (ToT ret) + viewRaw = M.View + { M.vName = demoteViewName @name + , M.vArgument = argNotes + , M.vReturn = retNotes + , M.vCode = compileLorentzWithOptions co viewCode + } + \\ niceViewableEvi @arg + \\ niceViewableEvi @ret + viewWithNecessaryCast + | argNotes == M.starNotes || coDisableInitialCast co = viewRaw + | Right{} <- typeCheckingWith def verify = viewRaw + | otherwise = viewRaw { + M.vCode = compileLorentzWithOptions co (I CAST # viewCode :: ViewCode arg st ret) } + in M.SomeView viewWithNecessaryCast {- | Set all the contract's views. @@ -371,7 +379,7 @@ makeLensesWith postfixLFields ''CompilationOptions cdCodeL :: - forall cp st vd cp1. (NiceParameterFull cp1, NiceStorage st) => + forall cp st vd cp1. NiceParameterFull cp1 => Lens.Lens (ContractData cp st vd) (ContractData cp1 st vd) (ContractCode cp st) (ContractCode cp1 st) cdCodeL f (ContractData code views options) = fmap (\code' -> ContractData code' views options) (f code) diff --git a/src/Lorentz/Run/Simple.hs b/src/Lorentz/Run/Simple.hs --- a/src/Lorentz/Run/Simple.hs +++ b/src/Lorentz/Run/Simple.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Running Lorentz code easily. -- @@ -13,8 +12,6 @@ , (<-$>) ) where -import Fmt (pretty) - import Lorentz.Base import Lorentz.Run import Lorentz.Value @@ -62,7 +59,7 @@ infixr 2 -$ (-$) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack) => inps :-> '[out] -> ZippedStack inps -> out -code -$ inp = either (error . pretty) id $ code -$? inp +code -$ inp = unsafe $ code -$? inp ---------------------------------------------------------------------------- -- Flipped versions diff --git a/src/Lorentz/StoreClass.hs b/src/Lorentz/StoreClass.hs --- a/src/Lorentz/StoreClass.hs +++ b/src/Lorentz/StoreClass.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -68,6 +67,8 @@ , stToEpStore , stGetEpStore , stSetEpStore + , sopGetField + , sopSetField -- * Implementations , storeFieldOpsADT @@ -107,7 +108,7 @@ ) where -import qualified Data.Kind as Kind +import Data.Kind qualified as Kind import GHC.TypeLits (KnownSymbol, Symbol) import Lorentz.ADT @@ -116,9 +117,9 @@ import Lorentz.Constraints import Lorentz.Errors (failUnexpected) import Lorentz.Ext -import qualified Lorentz.Instr as L +import Lorentz.Instr qualified as L import Lorentz.Iso -import qualified Lorentz.Macro as L +import Lorentz.Macro qualified as L import Lorentz.Value import Morley.Michelson.Text (labelToMText) @@ -205,18 +206,32 @@ { sopToField :: forall s. FieldRef fname -> store : s :-> ftype : s - , sopGetField - -- TODO: [#585] should be @Dupable ftype@ - -- here and everywhere below. - -- Though note that very complex functions that compose various ops - -- inherently require @(Dupable store)@. - :: forall s. (Dupable store) - => FieldRef fname -> store : s :-> ftype : store : s - , sopSetField - :: forall s. - FieldRef fname -> ftype : store : s :-> store : s + , sopGetFieldOpen + :: forall res s. (HasDupableGetters store) + => '[ftype] :-> '[res, ftype] + -> '[ftype] :-> '[res] + -> FieldRef fname -> store : s :-> res : store : s + -- ^ See 'getFieldOpen' for explanation of the signature. + , sopSetFieldOpen + :: forall new s. + '[new, ftype] :-> '[ftype] + -> FieldRef fname -> new : store : s :-> store : s + -- ^ See 'setFieldOpen' for explanation of the signature. } +-- | Simplified version of 'sopGetFieldOpen' where @res@ is @ftype@. +sopGetField + :: (Dupable ftype, HasDupableGetters store) + => StoreFieldOps store fname ftype + -> FieldRef fname -> store : s :-> ftype : store : s +sopGetField ops = sopGetFieldOpen ops L.dup L.nop + +-- | Simplified version of 'sopSetFieldOpen' where @res@ is @ftype@. +sopSetField + :: StoreFieldOps store fname ftype + -> FieldRef fname -> ftype : store : s :-> store : s +sopSetField ops = sopSetFieldOpen ops (L.dip L.drop) + -- Using fundeps here for the sake of less amount of boilerplate on user side, -- switch to type families if having any issues with that. -- | Provides operations on fields for storage. @@ -236,7 +251,7 @@ -- | Get storage field, preserving the storage itself on stack. stGetField - :: (StoreHasField store fname ftype, Dupable store) + :: (StoreHasField store fname ftype, Dupable ftype, HasDupableGetters store) => FieldRef fname -> store : s :-> ftype : store : s stGetField l = sopGetField storeFieldOps l @@ -250,9 +265,11 @@ -- | Version of 'stToFieldNamed' that preserves the storage on stack. stGetFieldNamed - :: (StoreHasField store fname ftype, FieldRefHasFinalName fname, Dupable ftype) + :: ( StoreHasField store fname ftype, FieldRefHasFinalName fname + , Dupable ftype, HasDupableGetters store + ) => FieldRef fname -> store : s :-> (FieldRefFinalName fname :! ftype) : store : s -stGetFieldNamed fr = stGetFieldNamed fr +stGetFieldNamed fr = stGetField fr # toNamed (fieldRefFinalName fr) -- | Update storage field. stSetField @@ -308,7 +325,7 @@ instance ( StoreHasField store name submap , StoreHasSubmap submap SelfRef key value , KnownSymbol name - , Dupable store + , HasDupableGetters store, Dupable submap ) => StoreHasSubmap store (name :: Symbol) key value where storeSubmapOps = storeSubmapOpsReferTo (fromLabel @name :-| this) storeSubmapOps @@ -387,8 +404,8 @@ Label epName -> store : s :-> (EntrypointLambda epParam epStore) : s , sopSetEpLambda - :: forall s. - Label epName + :: forall s. (HasDupableGetters store) + => Label epName -> (EntrypointLambda epParam epStore) : store : s :-> store : s , sopToEpStore :: forall s. @@ -432,7 +449,7 @@ -- | Stores the entrypoint lambda in the storage. Fails if already set. stSetEpLambda - :: StoreHasEntrypoint store epName epParam epStore + :: (StoreHasEntrypoint store epName epParam epStore, HasDupableGetters store) => Label epName -> (EntrypointLambda epParam epStore) : store : s :-> store : s stSetEpLambda = sopSetEpLambda storeEpOps @@ -466,8 +483,10 @@ => StoreFieldOps dt (fname :: Symbol) ftype storeFieldOpsADT = StoreFieldOps { sopToField = toField . fieldNameToLabel - , sopGetField = getField . fieldNameToLabel - , sopSetField = setField . fieldNameToLabel + , sopGetFieldOpen = \cont1 cont2 l -> + getFieldOpen cont1 cont2 (fieldNameToLabel l) + , sopSetFieldOpen = \cont l -> + setFieldOpen cont (fieldNameToLabel l) } -- | Implementation of 'StoreHasEntrypoint' for a datatype keeping a pack of @@ -477,7 +496,6 @@ :: ( HasFieldOfType store epmName (EntrypointsField epParam epStore) , HasFieldOfType store epsName epStore , KnownValue epParam, KnownValue epStore - , Dupable store ) => Label epmName -> Label epsName -> StoreEntrypointOps store epName epParam epStore @@ -495,7 +513,6 @@ :: ( StoreHasField store epmName (EntrypointsField epParam epStore) , StoreHasField store epsName epStore , KnownValue epParam, KnownValue epStore - , Dupable store ) => Label epmName -> Label epsName -> StoreEntrypointOps store epName epParam epStore @@ -534,7 +551,7 @@ storeFieldOpsDeeper :: ( HasFieldOfType storage fieldsPartName fields , StoreHasField fields fname ftype - , Dupable storage + , HasDupableGetters fields ) => FieldRef fieldsPartName -> StoreFieldOps storage fname ftype @@ -547,7 +564,8 @@ storeSubmapOpsDeeper :: ( HasFieldOfType storage bigMapPartName fields , StoreHasSubmap fields SelfRef key value - , Dupable storage + , HasDupableGetters storage + , Dupable fields ) => FieldRef bigMapPartName -> StoreSubmapOps storage mname key value @@ -561,7 +579,7 @@ storeEntrypointOpsDeeper :: ( HasFieldOfType store nameInStore substore , StoreHasEntrypoint substore epName epParam epStore - , Dupable store + , HasDupableGetters store, Dupable substore ) => FieldRef nameInStore -> StoreEntrypointOps store epName epParam epStore @@ -607,8 +625,8 @@ storeFieldOpsReferTo l StoreFieldOps{..} = StoreFieldOps { sopToField = \_l -> sopToField l - , sopGetField = \_l -> sopGetField l - , sopSetField = \_l -> sopSetField l + , sopGetFieldOpen = \cont1 cont2 _l -> sopGetFieldOpen cont1 cont2 l + , sopSetFieldOpen = \cont _l -> sopSetFieldOpen cont l } -- | Pretend that given 'StoreEntrypointOps' implementation is made up @@ -636,13 +654,26 @@ -- you can use -- @mapStoreFieldOps (namedIso #value)@ mapStoreFieldOps - :: LIso field1 field2 + :: forall field1 field2 store name. + KnownValue field1 + => LIso field1 field2 -> StoreFieldOps store name field1 -> StoreFieldOps store name field2 mapStoreFieldOps LIso{..} StoreFieldOps{..} = StoreFieldOps { sopToField = \l -> sopToField l # liTo - , sopGetField = \l -> sopGetField l # liTo - , sopSetField = \l -> liFrom # sopSetField l + , sopGetFieldOpen = \contWDup contWoDup l -> + let ourContWoDup = liTo # contWoDup + ourContWDup = case decideOnDupable @field1 of + -- We can avoid an iso roundtrip if we manage to duplicate `field1` + IsDupable -> L.dup # liTo # L.framed contWoDup + IsNotDupable -> liTo # contWDup # L.dip liFrom + in sopGetFieldOpen ourContWDup ourContWoDup l + , sopSetFieldOpen = \cont l -> + -- TODO [#560]: make sure @L.framed@ is transparent for the optimizer. + -- Calling @liTo@ is often redundant here since @cont@ is usually just + -- @L.dip L.drop@, this is not so only if we compose result of + -- @mapStoreFieldOps@ with other 'StoreFieldOps'. + sopSetFieldOpen (L.dip liTo # L.framed cont # liFrom) l } -- | Change submap operations so that they work on a modified key. @@ -691,7 +722,7 @@ -- Suits for a case when your store does not contain its fields directly -- rather has a nested structure. composeStoreFieldOps - :: (Dupable store) + :: HasDupableGetters substore => FieldRef nameInStore -> StoreFieldOps store nameInStore substore -> StoreFieldOps substore nameInSubstore field @@ -700,17 +731,23 @@ StoreFieldOps { sopToField = \l2 -> sopToField ops1 l1 # sopToField ops2 l2 - , sopGetField = \l2 -> - sopGetField ops1 l1 # sopToField ops2 l2 - , sopSetField = \l2 -> - L.dip (sopGetField ops1 l1) # - sopSetField ops2 l2 # - sopSetField ops1 l1 + , sopGetFieldOpen = \contWDup contWoDup l2 -> + sopGetFieldOpen ops1 + (sopGetFieldOpen ops2 contWDup contWoDup l2) + (sopToField ops2 l2 # contWoDup) + l1 + , sopSetFieldOpen = \cont l2 -> + sopSetFieldOpen ops1 (sopSetFieldOpen ops2 cont l2) l1 } -- | Chain implementations of field and submap operations. +-- +-- This requires @Dupable substore@ for simplicity, in most cases it is +-- possible to use a different chaining (@nameInStore :-| mname :-| this@) +-- to avoid that constraint. +-- If this constraint is still an issue, please create a ticket. composeStoreSubmapOps - :: (Dupable store) + :: (HasDupableGetters store, Dupable substore) => FieldRef nameInStore -> StoreFieldOps store nameInStore substore -> StoreSubmapOps substore mname key value @@ -811,8 +848,11 @@ L.swap ) +-- We still require 'Dupable substore' because substore with entrypoints +-- is likely to contain only lambdas and thus be dupable. +-- If there is a case when it is not, create an issue to generalize this code. composeStoreEntrypointOps - :: (Dupable store) + :: (HasDupableGetters store, Dupable substore) => FieldRef nameInStore -> StoreFieldOps store nameInStore substore -> StoreEntrypointOps substore epName epParam epStore @@ -985,7 +1025,7 @@ instance ( StoreHasField store field substore , StoreHasField substore subfield ty , KnownFieldRef field, KnownFieldRef subfield - , Dupable store + , HasDupableGetters substore ) => StoreHasField store (field :-| subfield) ty where storeFieldOps = @@ -995,7 +1035,7 @@ instance ( StoreHasField store field substore , StoreHasSubmap substore subfield key value , KnownFieldRef field, KnownFieldRef subfield - , Dupable store + , HasDupableGetters store, Dupable substore ) => StoreHasSubmap store (field :-| subfield) key value where storeSubmapOps = @@ -1026,8 +1066,8 @@ instance StoreHasField store SelfRef store where storeFieldOps = StoreFieldOps { sopToField = \SelfRef -> L.nop - , sopGetField = \SelfRef -> L.dup - , sopSetField = \SelfRef -> L.dip L.drop + , sopGetFieldOpen = \contWDup _ SelfRef -> L.framed contWDup + , sopSetFieldOpen = \cont SelfRef -> L.framed cont } instance (NiceComparable key, KnownValue value) => diff --git a/src/Lorentz/StoreClass/Extra.hs b/src/Lorentz/StoreClass/Extra.hs --- a/src/Lorentz/StoreClass/Extra.hs +++ b/src/Lorentz/StoreClass/Extra.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Some conveniences for "Lorentz.StoreClass" module. -- diff --git a/src/Lorentz/Tickets.hs b/src/Lorentz/Tickets.hs --- a/src/Lorentz/Tickets.hs +++ b/src/Lorentz/Tickets.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} @@ -96,7 +95,7 @@ ) where import Prelude (Generic, Typeable, ($)) -import qualified Prelude as P +import Prelude qualified as P import Lorentz.ADT import Lorentz.Annotation diff --git a/src/Lorentz/UParam.hs b/src/Lorentz/UParam.hs --- a/src/Lorentz/UParam.hs +++ b/src/Lorentz/UParam.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -47,12 +46,14 @@ , unwrapUParam ) where +import Debug qualified (show) + import Data.Constraint ((\\)) -import qualified Fcf +import Fcf qualified import Fmt (Buildable(..)) import GHC.Generics ((:*:)(..), (:+:)(..)) -import qualified GHC.Generics as G -import qualified Text.Show +import GHC.Generics qualified as G +import Text.Show qualified import Lorentz.ADT import Lorentz.Annotation (HasAnnotation) @@ -64,6 +65,7 @@ import Lorentz.Instr as L import Lorentz.Macro import Lorentz.Pack +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Text import Morley.Michelson.Typed import Morley.Util.Label (Label) @@ -87,6 +89,9 @@ deriving stock (Generic, Eq, Show) deriving anyclass (IsoValue, HasAnnotation, Unwrappable) +instance HasRPCRepr (UParam entries) where + type AsRPC (UParam entries) = UParam entries + -- Casting to homomorphic value ---------------------------------------------------------------------------- @@ -161,7 +166,7 @@ ConstrainedSome :: c a => a -> ConstrainedSome c instance Show (ConstrainedSome Show) where - show (ConstrainedSome a) = show a + show (ConstrainedSome a) = Debug.show a instance Buildable (ConstrainedSome Buildable) where build (ConstrainedSome a) = build a @@ -278,7 +283,7 @@ CaseUParam ((name ?: arg) ': entries) where unsafeCaseUParam (CaseClauseU clause :& clauses) fallback = dup # unwrapUParam # car # - push (unsafeMkMText $ symbolValT' @name) # eq # + push (unsafe . mkMText $ symbolValT' @name) # eq # if_ (unwrapUParam # cdr # unpackRaw # ifSome nop (failCustom_ #uparamArgumentUnpackFailed) # clause) (cutUParamEntry # unsafeCaseUParam clauses fallback) diff --git a/src/Lorentz/Util/TH.hs b/src/Lorentz/Util/TH.hs --- a/src/Lorentz/Util/TH.hs +++ b/src/Lorentz/Util/TH.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Lorentz template-haskell and quasiquote utilities. module Lorentz.Util.TH @@ -10,9 +9,9 @@ ) where import Data.Text (stripPrefix, stripSuffix) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax +import Language.Haskell.TH (Dec, ExpQ, Q, TypeQ, appT, conT, litE, litT, mkName, strTyLit, stringL) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (lift) import Prelude hiding (lift) import Lorentz.Doc diff --git a/src/Lorentz/Value.hs b/src/Lorentz/Value.hs --- a/src/Lorentz/Value.hs +++ b/src/Lorentz/Value.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE EmptyDataDeriving #-} @@ -59,6 +58,7 @@ , BinBase (..) -- * Constructors + , tz , toMutez , zeroMutez , oneMutez @@ -92,21 +92,22 @@ import Data.Constraint ((\\)) import Data.Default (Default(..)) import Data.Fixed (Fixed(..), HasResolution(..)) -import GHC.Num +import GHC.Num (fromInteger) import Prelude hiding (fromInteger) -import qualified Text.Show +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 qualified Morley.Michelson.Typed as M +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, zeroMutez) + toMutez, tz, zeroMutez) import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature) import Morley.Util.CustomGeneric as ReExports @@ -126,6 +127,9 @@ instance HasAnnotation Never where getAnnotation _ = M.starNotes +instance HasRPCRepr Never where + type AsRPC Never = Never + instance M.TypeHasDoc Never where typeDocMdDescription = "An uninhabited type." @@ -202,6 +206,9 @@ 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" diff --git a/src/Lorentz/ViewBase.hs b/src/Lorentz/ViewBase.hs --- a/src/Lorentz/ViewBase.hs +++ b/src/Lorentz/ViewBase.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Lorentz.ViewBase ( ViewTyInfo(..) @@ -24,11 +23,12 @@ ) where import Control.Monad.Except (throwError) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Singletons (demote) import Fmt (Buildable(..), pretty, (+|), (|+)) import Morley.Michelson.Typed +import Morley.Util.MismatchError import Morley.Util.TypeLits -- | Type-level information about a view. @@ -89,7 +89,7 @@ :: forall name. (KnownSymbol name, HasCallStack) => ViewName -demoteViewName = unsafeMkViewName (symbolValT' @name) +demoteViewName = unsafe . mkViewName $ symbolValT' @name -- | Interface of a single view at term-level. data ViewInterface = ViewInterface @@ -129,18 +129,18 @@ data ViewInterfaceMatchError = VIMViewNotFound ViewName - | VIMViewArgMismatch T T - | VIMViewRetMismatch T T + | VIMViewArgMismatch (MismatchError T) + | VIMViewRetMismatch (MismatchError T) deriving stock (Show, Eq) instance Buildable ViewInterfaceMatchError where build = \case VIMViewNotFound name -> "View not found in the contract " +| name |+ "" - VIMViewArgMismatch actual expected -> - "View argument type " +| actual |+ " does not match the expected " +| expected |+ "" - VIMViewRetMismatch actual expected -> - "View return type " +| actual |+ " does not match the expected " +| expected |+ "" + VIMViewArgMismatch merr -> + "View argument type mismatch.\n" +| merr |+ "" + VIMViewRetMismatch merr -> + "View return type mismatch.\n" +| merr |+ "" instance Exception ViewInterfaceMatchError where displayException = pretty @@ -155,9 +155,11 @@ Nothing -> throwError (VIMViewNotFound viName) Just (SomeView View{..}) -> do unless (notesT vArgument == viArg) $ - throwError (VIMViewArgMismatch (notesT vArgument) viArg) + throwError $ VIMViewArgMismatch MkMismatchError + { meExpected = viArg, meActual = notesT vArgument } unless (notesT vReturn == viRet) $ - throwError (VIMViewRetMismatch (notesT vReturn) viRet) + throwError $ VIMViewRetMismatch MkMismatchError + { meExpected = viRet, meActual = notesT vReturn } pass where viewsMap :: Map.Map ViewName (SomeView st) diff --git a/src/Lorentz/Wrappable.hs b/src/Lorentz/Wrappable.hs --- a/src/Lorentz/Wrappable.hs +++ b/src/Lorentz/Wrappable.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Permissions for casts between wrappers and their inner types. module Lorentz.Wrappable @@ -9,8 +8,8 @@ ) where import Data.Fixed (Fixed(..)) -import GHC.Generics -import GHC.TypeLits +import GHC.Generics (C1, D1, Generic(..), Meta(..), Rec0, S1) +import GHC.TypeLits (ErrorMessage(..), TypeError) import Morley.Michelson.Typed (ToT) import Morley.Util.Named diff --git a/src/Lorentz/Zip.hs b/src/Lorentz/Zip.hs --- a/src/Lorentz/Zip.hs +++ b/src/Lorentz/Zip.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -23,6 +22,7 @@ import Lorentz.Annotation import Lorentz.Base +import Morley.AsRPC (HasRPCRepr(..)) import Morley.Michelson.Typed import Morley.Michelson.Untyped (noAnn) @@ -116,3 +116,6 @@ getAnnotation b = NTLambda noAnn (getAnnotation @(ZippedStack i) b) (getAnnotation @(ZippedStack o) b) + +instance HasRPCRepr (inp :-> out) where + type AsRPC (inp :-> out) = inp :-> out