diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,28 @@ +0.13.4 +====== +* [!1078](https://gitlab.com/morley-framework/morley/-/merge_requests/1078) + Option to flatten EpdRecursive entrypoints in autodoc + + New entrypoint kind `FlattenedEntrypointsKindHiding`, which flattens + entrypoints in autodoc and allows hiding specific constructors. For other + intents it's the same as `PlainEntrypointsKind`. + + Convenience synonym `FlattenedEntrypointsKind` for cases where no hiding + is necessary. + + New convenience functions `entryCaseFlattened` and + `entryCaseFlattenedHiding`. + + Deprecate redundant `constructDEpArg`, use `mkDEntrypointArgSimple` instead. +* [!1104](https://gitlab.com/morley-framework/morley/-/merge_requests/1104) + Use clearer notation for (-$) + + Introduce new data types `ZippedStackRepr a b = a ::: b` + and `ZSNil = ZSNil`, isomorphic to '(a, b)' and '()' respectively, + to represent a zipped stack. +* [!1082](https://gitlab.com/morley-framework/morley/-/merge_requests/1082) + Fix/drop/comment noncanonical Show instances +* [!841](https://gitlab.com/morley-framework/morley/-/merge_requests/841) + Make entrypoints derivation work with void-like entrypoint arguments. + 0.13.3 ====== * [!1100](https://gitlab.com/morley-framework/morley/-/merge_requests/1100) @@ -155,7 +177,15 @@ instance implemented via `storeFieldOpsADT`. * If you have storage which is directly a map, use `this` instead of label to access the map. * If you have an instance for a complex storage which is not represented as simple ADT, - turn this instance into overlappable one. + turn this instance into overlappable one. Make sure that `name` type parameter is of + concrete type to avoid "overlapping instances" error. + * The pattern when a datatype transparently provides access to its inner fields via an + overlapping instance - may not work smoothly and produce "overlapping instances" error. + To mitigate this do one of the following: + * Specify the kind of `name` type parameter in your overlapping instance to be concrete + (i.e. `Symbol`). + * Use the new functionality to access the nested field by a fully qualified name. + * [!807](https://gitlab.com/morley-framework/morley/-/merge_requests/807) + Add some instances to `BigMap` and `TAddress` types. * [!787](https://gitlab.com/morley-framework/morley/-/merge_requests/787) 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.3 +version: 0.13.4 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 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 @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE InstanceSigs #-} -- | Utilities for declaring and documenting entry points. module Lorentz.Entrypoints.Doc @@ -12,6 +13,8 @@ , DEntrypointReference (..) , EntryArrow (..) , PlainEntrypointsKind + , FlattenedEntrypointsKind + , FlattenedEntrypointsKindHiding , CommonContractBehaviourKind , CommonEntrypointsBehaviourKind , diEntrypointToMarkdown @@ -38,22 +41,25 @@ , areFinalizedParamBuildingSteps , entryCaseSimple_ , entryCaseSimple + , entryCaseFlattened_ + , entryCaseFlattened + , entryCaseFlattenedHiding_ + , entryCaseFlattenedHiding , RequireFlatParamEps , RequireFlatEpDerivation ) where -import Debug qualified (show) - import Control.Lens.Cons (_head) import Data.Char (toLower) import Data.Constraint (Dict(..)) import Data.Map qualified as Map +import Data.Singletons (fromSing) import Data.Text qualified as T import Data.Vinyl.Core (RMap, rappend) +import Fcf (IsJust, type (@@)) import Fmt (Buildable(..), build, fmt, listF) import GHC.Generics ((:+:)) import GHC.Generics qualified as G -import Text.Show qualified import Lorentz.ADT import Lorentz.Annotation @@ -140,17 +146,43 @@ -- All such entrypoints will be placed under the same "entrypoints" section, -- and this instance defines characteristics of this section. class Typeable ep => EntrypointKindHasDoc (ep :: Type) where + -- | Can be used to make a kind equivalent to some other kind; + -- if changing this, 'entrypointKindPos' and 'entrypointKindSectionName' + -- will be ignored. + type EntrypointKindOverride ep + type EntrypointKindOverride ep = ep + + -- | Implement this when specifying 'EntrypointKindOverride'. + -- This should never be normally used, but because @MINIMAL@ pragma + -- can't specify type families, we use this hack. + -- + -- Default implementation is a bottom (i.e. a runtime error). + -- + -- If implemented, it should be + -- + -- > entrypointKindOverrideSpecified = Dict + entrypointKindOverrideSpecified :: Dict ((EntrypointKindOverride ep == ep) ~ False) + entrypointKindOverrideSpecified = error "Called entrypointKindOverrideSpecified" + -- | Position of the respective entrypoints section in the doc. -- This shares the same positions space with all other doc items. entrypointKindPos :: Natural + default entrypointKindPos :: EntrypointKindHasDoc (EntrypointKindOverride ep) => Natural + entrypointKindPos = entrypointKindPos @(EntrypointKindOverride ep) -- | Name of the respective entrypoints section. entrypointKindSectionName :: Text + default entrypointKindSectionName :: EntrypointKindHasDoc (EntrypointKindOverride ep) => Text + entrypointKindSectionName = entrypointKindSectionName @(EntrypointKindOverride ep) -- | Description in the respective entrypoints section. entrypointKindSectionDescription :: Maybe Markdown entrypointKindSectionDescription = Nothing + {-# MINIMAL entrypointKindOverrideSpecified | (entrypointKindPos, entrypointKindSectionName) #-} + +{-# WARNING entrypointKindOverrideSpecified "Normally you should never need to use this function" #-} + instance EntrypointKindHasDoc ep => DocItem (DEntrypoint ep) where type DocItemPlacement (DEntrypoint ep) = 'DocItemInlined type DocItemReferenced (DEntrypoint ep) = 'True @@ -180,6 +212,34 @@ entrypointKindPos = 1000 entrypointKindSectionName = "Entrypoints" +-- | Special entrypoint kind that flattens one level of recursive entrypoints. +-- +-- With 'EpdRecursive', intermediary nodes are hidden from documentation. +-- +-- With 'EpdDelegate', intermediary nodes will still be shown. +-- +-- Any entrypoints can be omitted from docs by listing those in the type +-- parameter (which is especially helpful with 'EpdDelegate'). +-- +-- For other entrypoint derivation strategies (e.g. 'EpdPlain'), behaves like +-- 'PlainEntrypointsKind' (with the exception of hiding entrypoints from docs) +-- +-- If you have several levels of recursion, each level will need to have this +-- kind. +-- +-- Note that list of entrypoints to be hidden is not checked by default. Use +-- 'entryCaseFlattenedHiding' to have a static check that entrypoints to be +-- hidden do indeed exist. +data FlattenedEntrypointsKindHiding (hiddenEntrypoints :: [Symbol]) + +-- | A convenience type synonym for 'FlattenedEntrypointsKindHiding' not hiding +-- any entrypoitns. +type FlattenedEntrypointsKind = FlattenedEntrypointsKindHiding '[] + +instance Typeable heps => EntrypointKindHasDoc (FlattenedEntrypointsKindHiding heps) where + type EntrypointKindOverride (FlattenedEntrypointsKindHiding heps) = PlainEntrypointsKind + entrypointKindOverrideSpecified = Dict + -- | Describes the behaviour common for all entrypoints. -- -- For instance, if your contract runs some checks before calling any @@ -236,11 +296,6 @@ instance Buildable ParamBuilder where build = pbSample -instance Show ParamBuilder where - show (ParamBuilder pb) = - -- Using @'x'@ symbol here because unicode does not render well in 'show' - "ParamBuilder " <> Debug.show (pb "x") - instance Eq ParamBuilder where (==) = (==) `on` pbSample @@ -251,7 +306,7 @@ -- ^ How to construct parameter in Haskell code. , pbdMichelson :: ParamBuilder -- ^ How to construct parameter working on raw Michelson. - } deriving stock (Show, Eq) + } deriving stock (Eq) -- | Describes a parameter building step. -- @@ -274,7 +329,7 @@ -- It contains dummy 'ParamBuildingStep's which were assigned before -- entrypoints were taken into account. | PbsUncallable [ParamBuildingStep] - deriving stock (Show, Eq) + deriving stock (Eq) instance Buildable ParamBuildingStep where build = \case @@ -315,16 +370,9 @@ -- into @Service1@ constructor. } -constructDEpArg - :: forall arg. - ( NiceParameter arg - , TypeHasDoc arg - ) - => DEntrypointArg -constructDEpArg = DEntrypointArg - { epaArg = Just $ SomeEntrypointArg (Proxy @arg) - , epaBuilding = [] - } +constructDEpArg :: forall arg. (NiceParameter arg, TypeHasDoc arg) => DEntrypointArg +constructDEpArg = mkDEntrypointArgSimple @arg +{-# DEPRECATED constructDEpArg "Use `mkDEntrypointArgSimple` instead" #-} emptyDEpArg :: DEntrypointArg emptyDEpArg = DEntrypointArg @@ -335,12 +383,7 @@ mkDEpUType :: forall t. HasAnnotation t => Untyped.Ty mkDEpUType = mkUType (getAnnotation @t FollowEntrypoint) -mkDEntrypointArgSimple - :: forall t. - ( NiceParameter t - , TypeHasDoc t - ) - => DEntrypointArg +mkDEntrypointArgSimple :: forall t. (NiceParameter t, TypeHasDoc t) => DEntrypointArg mkDEntrypointArgSimple = DEntrypointArg { epaArg = Just $ SomeEntrypointArg (Proxy @t) , epaBuilding = [] @@ -443,7 +486,7 @@ => DeriveCtorFieldDoc con ('OneField ty) where - deriveCtorFieldDoc = constructDEpArg @ty + deriveCtorFieldDoc = mkDEntrypointArgSimple @ty -- | Add necessary documentation to entry points. documentEntrypoints @@ -451,16 +494,20 @@ DocumentEntrypoints kind a => Rec (CaseClauseL inp out) (CaseClauses a) -> Rec (CaseClauseL inp out) (CaseClauses a) -documentEntrypoints = gDocumentEntrypoints @kind @(G.Rep a) (ParamBuilder id) +documentEntrypoints = + gDocumentEntrypoints @(BuildEPTree' a) @kind @(G.Rep a) $ + ParamBuilder id -- | Constraint for 'documentEntrypoints'. type DocumentEntrypoints kind a = - (Generic a, GDocumentEntrypoints kind (G.Rep a)) + (Generic a, GDocumentEntrypoints (BuildEPTree' a) kind (G.Rep a)) +type BuildEPTree' a = BuildEPTree (GetParameterEpDerivation a) a + -- | Traverse entry points and add parameter building step (which describes -- necessity to wrap parameter into some constructor of the given datatype) -- to all parameters described within given code. -class GDocumentEntrypoints (kind :: Type) (x :: Type -> Type) where +class GDocumentEntrypoints (ept :: EPTree) (kind :: Type) (x :: Type -> Type) where -- | Add corresponding parameter building step. -- -- First argument is accumulator for Michelson description of the building step. @@ -469,38 +516,72 @@ -> Rec (CaseClauseL inp out) (GCaseClauses x) -> Rec (CaseClauseL inp out) (GCaseClauses x) -instance GDocumentEntrypoints kind x => GDocumentEntrypoints kind (G.D1 i x) where - gDocumentEntrypoints = gDocumentEntrypoints @kind @x +instance GDocumentEntrypoints ept kind x => GDocumentEntrypoints ept kind (G.D1 i x) where + gDocumentEntrypoints = gDocumentEntrypoints @ept @kind @x -instance ( GDocumentEntrypoints kind x, GDocumentEntrypoints kind y +instance ( GDocumentEntrypoints eptl kind x, GDocumentEntrypoints eptr kind y , RSplit (GCaseClauses x) (GCaseClauses y) ) => - GDocumentEntrypoints kind (x :+: y) where + GDocumentEntrypoints ('EPNode eptl eptr) kind (x :+: y) where gDocumentEntrypoints (ParamBuilder michDesc) clauses = let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses - in gDocumentEntrypoints @kind @x + in gDocumentEntrypoints @eptl @kind @x (ParamBuilder $ \a -> michDesc $ "Left (" <> a <> ")") lclauses `rappend` - gDocumentEntrypoints @kind @y + gDocumentEntrypoints @eptr @kind @y (ParamBuilder $ \a -> michDesc $ "Right (" <> a <> ")") rclauses -instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x +instance {-# OVERLAPPABLE #-} + ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x , KnownSymbol ctor - , DocItem (DEntrypoint kind) + , DocItem (DEntrypoint (EntrypointKindOverride kind)) , DeriveCtorFieldDoc ctor cf ) => - GDocumentEntrypoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where + GDocumentEntrypoints ept kind (G.C1 ('G.MetaCons ctor _1 _2) x) where gDocumentEntrypoints michDesc (CaseClauseL clause :& RNil) = let entrypointName = toText $ symbolVal (Proxy @ctor) psteps = mkPbsWrapIn entrypointName michDesc addDoc instr = clarifyParamBuildingSteps psteps $ - docGroup (DEntrypoint @kind entrypointName) $ + docGroup (DEntrypoint @(EntrypointKindOverride kind) entrypointName) $ doc (deriveCtorFieldDoc @ctor @cf) # instr in CaseClauseL (addDoc clause) :& RNil +instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x + , KnownSymbol ctor + ) => + GDocumentEntrypoints ('EPNode a b) (FlattenedEntrypointsKindHiding _heps) + (G.C1 ('G.MetaCons ctor _1 _2) x) where + gDocumentEntrypoints michDesc (CaseClauseL clause :& RNil) = + let entrypointName = toText $ symbolVal (Proxy @ctor) + psteps = mkPbsWrapIn entrypointName michDesc + in CaseClauseL (clarifyParamBuildingSteps psteps clause) :& RNil + +instance {-# OVERLAPPABLE #-} + ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x + , KnownSymbol ctor + , DeriveCtorFieldDoc ctor cf + , T.SingI heps + ) => + GDocumentEntrypoints ept (FlattenedEntrypointsKindHiding heps) + (G.C1 ('G.MetaCons ctor _1 _2) x) where + gDocumentEntrypoints michDesc (CaseClauseL clause :& RNil) = + let epName = toText $ symbolVal (Proxy @ctor) + psteps = mkPbsWrapIn epName michDesc + hiddenEps = fromSing $ T.sing @heps + epDoc instr + | epName `elem` hiddenEps = instr + | otherwise = + docGroup (DEntrypoint @PlainEntrypointsKind epName) + (doc (deriveCtorFieldDoc @ctor @cf)) + # instr + addDoc instr = + clarifyParamBuildingSteps psteps $ + epDoc instr + in CaseClauseL (addDoc clause) :& RNil + -- | Like 'case_', to be used for pattern-matching on a parameter -- or its part. -- @@ -543,7 +624,7 @@ documentEntrypoint instr = let entrypointName = toText $ symbolVal (Proxy @epName) in docGroup (DEntrypoint @kind entrypointName) $ - doc (constructDEpArg @param) # instr + doc (mkDEntrypointArgSimple @param) # instr -- | Provides arror for convenient entrypoint documentation class EntryArrow kind name body where @@ -650,6 +731,7 @@ PbsUncallable{} -> True in any hasFinalizationTraces +-- | Version of 'entryCase_' for contracts with flat parameter. entryCaseSimple_ :: forall cp out inp. ( InstrCaseC cp @@ -664,8 +746,7 @@ where _reqFlat = Dict @(RequireFlatEpDerivation cp (GetParameterEpDerivation cp)) --- | Version of 'entryCase' for contracts with flat parameter, use it when you --- need only one 'entryCase' all over the contract implementation. +-- | Version of 'entryCase' for contracts with flat parameter. entryCaseSimple :: forall cp out inp clauses. ( CaseTC cp out inp clauses @@ -675,6 +756,68 @@ => IsoRecTuple clauses -> cp : inp :-> out entryCaseSimple = entryCaseSimple_ . recFromTuple +-- | Version of 'entryCase_' for contracts with recursive parameter that needs +-- to be flattened. Use it with 'EpdRecursive' when you don't need intermediary +-- nodes in autodoc. +entryCaseFlattened_ + :: forall cp out inp. + ( InstrCaseC cp + , RMap (CaseClauses cp) + , DocumentEntrypoints FlattenedEntrypointsKind cp + ) + => Rec (CaseClauseL inp out) (CaseClauses cp) + -> cp : inp :-> out +entryCaseFlattened_ = + entryCase_ (Proxy @FlattenedEntrypointsKind) + +-- | Version of 'entryCase' for contracts with recursive parameter that needs +-- to be flattened. Use it with 'EpdRecursive' when you don't need intermediary +-- nodes in autodoc. +entryCaseFlattened + :: forall cp out inp clauses. + ( CaseTC cp out inp clauses + , DocumentEntrypoints FlattenedEntrypointsKind cp + ) + => IsoRecTuple clauses -> cp : inp :-> out +entryCaseFlattened = entryCaseFlattened_ . recFromTuple + +-- | Version of 'entryCase_' for contracts with recursive delegate parameter that needs +-- to be flattened. Use it with 'EpdDelegate' when you don't need hierarchical +-- entrypoints in autodoc. You can also hide particular entrypoints with the +-- type parameter. Consider using 'entryCaseFlattened_' if you don't want +-- to hide any entrypoints. +entryCaseFlattenedHiding_ + :: forall heps cp out inp. + ( InstrCaseC cp + , RMap (CaseClauses cp) + , DocumentEntrypoints (FlattenedEntrypointsKindHiding heps) cp + , HasEntrypoints (ParameterEntrypointsDerivation cp) cp heps + ) + => Rec (CaseClauseL inp out) (CaseClauses cp) + -> cp : inp :-> out +entryCaseFlattenedHiding_ = + entryCase_ (Proxy @(FlattenedEntrypointsKindHiding heps)) + where + _reqHasEps = Dict @(HasEntrypoints (ParameterEntrypointsDerivation cp) cp heps) + +-- | Version of 'entryCase' for contracts with recursive delegate parameter that needs +-- to be flattened. Use it with 'EpdDelegate' when you don't need hierarchical +-- entrypoints in autodoc. You can also hide particular entrypoints with the +-- first type parameter. Consider using 'entryCaseFlattened' if you don't want +-- to hide any entrypoints. +-- +-- @ +-- entryCaseFlattenedHiding @'["Ep1", "Ep2"] ... +-- @ +entryCaseFlattenedHiding + :: forall heps cp out inp clauses. + ( CaseTC cp out inp clauses + , DocumentEntrypoints (FlattenedEntrypointsKindHiding heps) cp + , HasEntrypoints (ParameterEntrypointsDerivation cp) cp heps + ) + => IsoRecTuple clauses -> cp : inp :-> out +entryCaseFlattenedHiding = entryCaseFlattenedHiding_ @heps . recFromTuple + type family RequireFlatParamEps cp :: Constraint where RequireFlatParamEps cp = ( NiceParameterFull cp @@ -691,6 +834,15 @@ 'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$: 'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`" ) + +type family HasEntrypoints mode cp syms :: Constraint where + HasEntrypoints mode cp (x ': xs) = + If (IsJust @@ (EpdLookupEntrypoint mode cp @@ x)) + (HasEntrypoints mode cp xs) + (TypeError + ('Text "Parameter type " ':<>: 'ShowType cp + ':<>: 'Text " does not contain entrypoint " ':<>: 'ShowType x)) + HasEntrypoints _ _ '[] = () --------------------------- -- Helper 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 @@ -169,6 +169,8 @@ GBuildEntrypointsTree mode x GBuildEntrypointsTree mode (x G.:+: y) = 'EPNode (GBuildEntrypointsTree mode x) (GBuildEntrypointsTree mode y) + GBuildEntrypointsTree _ G.V1 = + 'EPLeaf GBuildEntrypointsTree EpdPlain (G.C1 _ _) = 'EPLeaf @@ -351,6 +353,13 @@ instance GEntrypointsNotes mode 'EPLeaf G.U1 where type GAllEntrypoints mode 'EPLeaf G.U1 = '[] type GLookupEntrypoint mode 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing + gMkEntrypointsNotes = (starNotes, noAnn) + gMkEpLiftSequence _ = EpConstructionFailed + gMkDescs = RNil + +instance GEntrypointsNotes mode 'EPLeaf G.V1 where + type GAllEntrypoints mode 'EPLeaf G.V1 = '[] + type GLookupEntrypoint mode 'EPLeaf G.V1 = Fcf.ConstFn 'Nothing gMkEntrypointsNotes = (starNotes, noAnn) gMkEpLiftSequence _ = EpConstructionFailed gMkDescs = RNil diff --git a/src/Lorentz/Errors.hs b/src/Lorentz/Errors.hs --- a/src/Lorentz/Errors.hs +++ b/src/Lorentz/Errors.hs @@ -49,14 +49,11 @@ , errorTagToMText ) where -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 Text.Show qualified import Lorentz.Base import Lorentz.Doc @@ -257,9 +254,6 @@ instance Buildable SomeError where build (SomeError e) = errorToVal e (build . untypeValue) -instance Show SomeError where - show = pretty - ---------------------------------------------------------------------------- -- General instructions ---------------------------------------------------------------------------- @@ -485,11 +479,6 @@ -- Special treatment of no-arg errors ---------------------------------------------------------------------------- - -instance Eq (CustomErrorRep tag) => Eq (() -> CustomError tag) where - e1 == e2 = e1 () == e2 () -instance Show (CustomErrorRep tag) => Show (() -> CustomError tag) where - 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. diff --git a/src/Lorentz/Ext.hs b/src/Lorentz/Ext.hs --- a/src/Lorentz/Ext.hs +++ b/src/Lorentz/Ext.hs @@ -81,7 +81,7 @@ stackType :: forall s. s :-> s stackType = I Nop -_sample1 :: s ~ (a : s') => s :-> s +_sample1 :: (s ~ (a : s')) => s :-> s _sample1 = printComment $ "Head is " <> stackRef @0 _sample2 :: Integer : Natural : s :-> Integer : Natural : s diff --git a/src/Lorentz/Macro.hs b/src/Lorentz/Macro.hs --- a/src/Lorentz/Macro.hs +++ b/src/Lorentz/Macro.hs @@ -383,11 +383,11 @@ -- of arguments. -- -- Given a stack of 3 elements, --- >>> arg = (1 :: Integer, (2 :: Integer, 3 :: Integer)) +-- >>> arg = (1 :: Integer) ::: (2 :: Integer) ::: (3 :: Integer) -- -- @framedN@ will have access to exactly the number of elements specified, -- >>> framedN @1 drop -$ arg --- (2,3) +-- 2 ::: 3 -- >>> framedN @1 (drop # drop) -$ arg -- ... -- ... error: @@ -403,7 +403,8 @@ -- >>> framedN @5 (drop # drop # drop # drop) -$ arg -- ... -- ... error: --- ... Couldn't match type ‘Integer’ with ‘(a0, (a1, out))’ +-- ... Couldn't match type ‘Integer’ +-- ... with ‘ZippedStackRepr a0 (ZippedStackRepr a1 out)’ -- ... framedN @@ -452,7 +453,7 @@ -- >>> papair == pair # pair -- True -- --- >>> papair -$ (True, (1, ())) +-- >>> papair -$ True ::: 1 ::: () -- ((True,1),()) papair :: a : b : c : s :-> ((a, b), c) : s papair = pair # pair @@ -461,7 +462,7 @@ -- >>> ppaiir == dip pair # pair -- True -- --- >>> ppaiir -$ (True, (1, ())) +-- >>> ppaiir -$ True ::: 1 ::: () -- (True,(1,())) ppaiir :: a : b : c : s :-> (a, (b, c)) : s ppaiir = dip pair # pair @@ -506,7 +507,7 @@ -- >>> setCar == cdr # swap # pair -- True -- --- >>> setCar -$ ((True, 1), ()) +-- >>> setCar -$ (True, 1) ::: () -- ((),1) setCar :: (a, b1) : (b2 : s) :-> (b2, b1) : s setCar = cdr # swap # pair @@ -515,7 +516,7 @@ -- >>> setCdr == car # pair -- True -- --- >>> setCdr -$ ((True, 1), ()) +-- >>> setCdr -$ (True, 1) ::: () -- (True,()) setCdr :: (a, b1) : (b2 : s) :-> (a, b2) : s setCdr = car # pair @@ -573,10 +574,10 @@ -- >>> when_ (push 5 # add @Integer @Integer) == if_ (push 5 # add @Integer @Integer) nop -- True -- --- >>> when_ (push 5 # add @Integer) -$ (True, 3) +-- >>> when_ (push 5 # add @Integer) -$ True ::: 3 -- 8 -- --- >>> when_ (push 5 # add @Integer) -$ (False, 3) +-- >>> when_ (push 5 # add @Integer) -$ False ::: 3 -- 3 when_ :: (s :-> s) -> (Bool : s :-> s) when_ i = if_ i nop @@ -585,10 +586,10 @@ -- >>> unless_ (push 5 # add @Integer @Integer) == if_ nop (push 5 # add @Integer @Integer) -- True -- --- >>> unless_ (push 5 # add @Integer) -$ (True, 3) +-- >>> unless_ (push 5 # add @Integer) -$ True ::: 3 -- 3 -- --- >>> unless_ (push 5 # add @Integer) -$ (False, 3) +-- >>> unless_ (push 5 # add @Integer) -$ False ::: 3 -- 8 unless_ :: (s :-> s) -> (Bool : s :-> s) unless_ i = if_ nop i @@ -597,7 +598,7 @@ -- >>> whenSome drop == ifSome drop nop -- True -- --- >>> whenSome drop -$ (Just 1 :: Maybe Integer, ()) +-- >>> whenSome drop -$ Just 1 ::: () -- () whenSome :: (a : s :-> s) -> (Maybe a : s :-> s) whenSome i = ifSome i nop 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 @@ -10,6 +10,8 @@ , (&?-) , (&-) , (<-$>) + , ZippedStackRepr(..) + , ZSNil(..) ) where import Lorentz.Base @@ -45,16 +47,19 @@ -- | Like @'-$?'@, assumes that no failure is possible. -- --- For testing and demonstration purposes. Note, that here types of variables are specified, because --- the result type of arithmetic operations depends on them. +-- For testing and demonstration purposes. Note, that we specify the result type of polymorphic +-- operations to avoid ambiguity arising from polymorphic literals. -- +-- Use 'ZippedStackRepr' to represent stack of two or more elements, and 'ZSNil' for empty stacks. +-- Stacks of one element are represented by the element itself. +-- -- >>> nop -$ 5 -- 5 --- >>> sub -$ ((3 :: Integer), (2 :: Integer)) +-- >>> sub -$ 3 ::: 2 :: Integer -- 1 --- >>> push 9 -$ () +-- >>> push 9 -$ ZSNil -- 9 --- >>> add # add -$ ((1 :: Integer), ((2 :: Integer), (3 :: Integer))) +-- >>> add # add -$ 1 ::: 2 ::: 3 :: Integer -- 6 infixr 2 -$ (-$) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack) diff --git a/src/Lorentz/UParam.hs b/src/Lorentz/UParam.hs --- a/src/Lorentz/UParam.hs +++ b/src/Lorentz/UParam.hs @@ -46,14 +46,11 @@ , unwrapUParam ) where -import Debug qualified (show) - import Data.Constraint ((\\)) import Fcf qualified import Fmt (Buildable(..)) import GHC.Generics ((:*:)(..), (:+:)(..)) import GHC.Generics qualified as G -import Text.Show qualified import Lorentz.ADT import Lorentz.Annotation (HasAnnotation) @@ -165,8 +162,7 @@ data ConstrainedSome (c :: Type -> Constraint) where ConstrainedSome :: c a => a -> ConstrainedSome c -instance Show (ConstrainedSome Show) where - show (ConstrainedSome a) = Debug.show a +deriving stock instance Show (ConstrainedSome Show) instance Buildable (ConstrainedSome Buildable) where build (ConstrainedSome a) = build a diff --git a/src/Lorentz/Value.hs b/src/Lorentz/Value.hs --- a/src/Lorentz/Value.hs +++ b/src/Lorentz/Value.hs @@ -173,7 +173,7 @@ convertNFixedToFixed (MkNFixed a) = MkFixed (fromIntegral a) instance (HasResolution a) => Show (NFixed a) where - show = show . convertNFixedToFixed + showsPrec d = Text.Show.showsPrec d . convertNFixedToFixed -- Note: This instances are copies of those in Data.Fixed for Fixed datatype instance (HasResolution a) => Num (NFixed a) where diff --git a/src/Lorentz/Zip.hs b/src/Lorentz/Zip.hs --- a/src/Lorentz/Zip.hs +++ b/src/Lorentz/Zip.hs @@ -16,6 +16,8 @@ , ZipInstrs , zippingStack , unzippingStack + , ZippedStackRepr(..) + , ZSNil(..) ) where import Prelude hiding (drop) @@ -49,6 +51,18 @@ on this module. -} +infixr 5 ::: +-- | A type used to represent a zipped stack of at least two elements, +-- isomorphic to a pair and represented as such in Michelson. +data ZippedStackRepr a b = a ::: b + deriving stock (Show, Eq, Generic) + deriving anyclass (IsoValue) +-- | A type used to represent an empty zipped stack, isomorphic to a unit and +-- represented as such in Michelson. +data ZSNil = ZSNil + deriving stock (Show, Eq, Generic) + deriving anyclass (IsoValue) + -- | Zipping stack into tuple and back. class (KnownIsoT (ZippedStack s)) => ZipInstr (s :: [Type]) where -- | A type which contains the whole stack zipped. @@ -70,7 +84,7 @@ unzipInstr = I (unzipInstrTyped @s) instance ZipInstr '[] where - type ZippedStack '[] = () + type ZippedStack '[] = ZSNil zipInstrTyped = UNIT unzipInstrTyped = DROP @@ -82,7 +96,7 @@ -- | Such definition seems the only possible one we can support -- efficiently. instance (ZipInstr (b ': s), KnownIsoT a) => ZipInstr (a ': b ': s) where - type ZippedStack (a ': b ': s) = (a, ZippedStack (b ': s)) + type ZippedStack (a ': b ': s) = ZippedStackRepr a (ZippedStack (b ': s)) zipInstrTyped = DIP (zipInstrTyped @(b ': s)) `seqOpt` PAIR unzipInstrTyped = UNPAIR `seqOpt` DIP (unzipInstrTyped @(b ': s))