diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,14 @@ +0.9.0 +===== +* [!731](https://gitlab.com/morley-framework/morley/-/merge_requests/731) + Added `GenericStrategy`-ies for compatibility with LIGO. +* [!712](https://gitlab.com/morley-framework/morley/-/merge_requests/712) + Add lenses for Lorentz contract config. +* [!684](https://gitlab.com/morley-framework/morley/-/merge_requests/684) + + Simplify working with autodoc in contracts (breaking change). + + `finalizeParamCallingDoc` is now applied automatically when lorentz' `Contract` + is used, no need to call it manually. + 0.8.0 ===== * [!671](https://gitlab.com/morley-framework/morley/-/merge_requests/671) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,8 +24,9 @@ You can find Lorentz instructions in [`Lorentz`](http://hackage.haskell.org/package/lorentz/docs/Lorentz.html) modules. -Examples of using Lorentz eDSL reside in the [`morley-multisig`](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley-multisig) package. -For more information, refer to that package's [README](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley-multisig/README.md). +Examples of using Lorentz eDSL reside in the [`morley-ledgers`](https://gitlab.com/morley-framework/morley-ledgers) +or [`tezos-btc`](https://github.com/tz-wrapped/tezos-btc) repos. +For more information, refer to that README's in the corresponding repositories. Also, to get more information about Lorentz you can read our [blogpost](https://serokell.io/blog/lorentz-implementing-smart-contract-edsl-in-haskell). @@ -127,7 +128,7 @@ deriving anyclass instance HasAnnotation MeasurementMethod instance TypeHasDoc MeasurementMethod where - typeDocName _ = "MeasurmentMethod" + typeDocName _ = "MeasurementMethod" typeDocMdDescription = "This type defines the way of measuring boa length. \ \Single boa constrictor corresponds to 38 parrot steps, 31 monkey step \ @@ -145,7 +146,7 @@ type Storage = Natural measureBoaConstrictor :: ContractCode Parameter Storage -measureBoaConstrictor = contractName "Boa constrictor measurement" $ do +measureBoaConstrictor = docGroup (DName "Boa constrictor measurement") $ do doc $ DDescription "This contract measures boa constrictor." unpair dip drop 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.8.0 +version: 0.9.0 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/ADT.hs b/src/Lorentz/ADT.hs --- a/src/Lorentz/ADT.hs +++ b/src/Lorentz/ADT.hs @@ -50,9 +50,9 @@ import Lorentz.Base import Lorentz.Coercions -import Lorentz.Instr import Michelson.Typed.Haskell.Instr import Michelson.Typed.Haskell.Value +import Michelson.Typed.Instr import Util.Label (Label) import Util.Type (type (++), KnownList) import Util.TypeTuple @@ -104,7 +104,7 @@ :: forall dt name st. InstrGetFieldC dt name => Label name -> dt : st :-> GetFieldType dt name : dt ': st -getField l = dup # toField @dt l +getField l = I DUP # toField @dt l -- | Like 'getField', but leaves field named. getFieldNamed diff --git a/src/Lorentz/Coercions.hs b/src/Lorentz/Coercions.hs --- a/src/Lorentz/Coercions.hs +++ b/src/Lorentz/Coercions.hs @@ -42,7 +42,6 @@ import Lorentz.Address import Lorentz.Base import Lorentz.Bytes -import Lorentz.Instr import Lorentz.Value import Lorentz.Wrappable (Wrappable(..)) import Lorentz.Zip @@ -84,7 +83,7 @@ -- | Convert between two stacks via failing. fakeCoerce :: s1 :-> s2 -fakeCoerce = unit # I FAILWITH +fakeCoerce = I (UNIT `Seq` FAILWITH) fakeCoercing :: (s1 :-> s2) -> s1' :-> s2' fakeCoercing i = fakeCoerce # iForceNotFail i # fakeCoerce diff --git a/src/Lorentz/ContractRegistry.hs b/src/Lorentz/ContractRegistry.hs --- a/src/Lorentz/ContractRegistry.hs +++ b/src/Lorentz/ContractRegistry.hs @@ -92,7 +92,7 @@ if ciIsDocumented then writeFunc (toString name <> ".md") mOutput $ - contractDocToMarkdown $ buildLorentzDocWithGitRev gitRev $ cCode ciContract + buildMarkdownDoc $ attachDocCommons gitRev ciContract else die "This contract is not documented" data SomeNiceStorage where diff --git a/src/Lorentz/Doc.hs b/src/Lorentz/Doc.hs --- a/src/Lorentz/Doc.hs +++ b/src/Lorentz/Doc.hs @@ -7,6 +7,7 @@ module Lorentz.Doc ( doc , docGroup + , dStorage , docStorage , buildLorentzDoc , buildLorentzDocWithGitRev @@ -33,6 +34,8 @@ , SubDoc (..) , DocGrouping , ContractDoc (..) + , DGeneralInfoSection (..) + , DName (..) , DDescription (..) , DEntrypointExample (..) , mkDEntrypointExample @@ -48,6 +51,14 @@ , contractDocToMarkdown , subDocToMarkdown , docItemSectionRef + , ContainsDoc (..) + , ContainsUpdateableDoc (..) + , WithFinalizedDoc + , finalizedAsIs + , buildDoc + , buildMarkdownDoc + , modifyDoc + , attachDocCommons , TypeHasDoc (..) , SomeTypeWithDoc (..) @@ -91,26 +102,32 @@ -- | Group documentation built in the given piece of code -- into block dedicated to one thing, e.g. to one entrypoint. -docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out) -docGroup gr = iMapAnyCode (DocGroup gr) +-- +-- Examples of doc items you can pass here: 'DName', 'DGeneralInfoSection'. +docGroup :: DocItem di => (SubDoc -> di) -> (inp :-> out) -> (inp :-> out) +docGroup gr = iMapAnyCode (DocGroup $ SomeDocItem . gr) -- | Insert documentation of the contract storage type. The type -- should be passed using type applications. +{-# DEPRECATED docStorage "Use `doc (dStorage @storage)` instead." #-} docStorage :: forall storage s. TypeHasDoc storage => s :-> s docStorage = doc $ DStorageType $ DType $ Proxy @storage -- | Give a name to given contract. Apply it to the whole contract code. +{-# DEPRECATED contractName "Use `docGroup name` instead." #-} contractName :: Text -> (inp :-> out) -> (inp :-> out) -contractName name = docGroup (SomeDocItem . DName name) +contractName name = docGroup (DName name) +{-# DEPRECATED buildLorentzDoc "Use 'buildDoc' instead." #-} buildLorentzDoc :: inp :-> out -> ContractDoc -buildLorentzDoc (iAnyCode -> code) = buildInstrDoc code +buildLorentzDoc = buildDocUnfinalized -- | Takes an instruction that inserts documentation items with -- general information about the contract. Inserts it into general -- section. See 'DGeneralInfoSection'. +{-# DEPRECATED contractGeneral "Use `docGroup DGeneralInfoSection` instead." #-} contractGeneral :: (inp :-> out) -> (inp :-> out) -contractGeneral = docGroup (SomeDocItem . DGeneralInfoSection) +contractGeneral = docGroup DGeneralInfoSection -- | Inserts general information about the contract using the default format. -- @@ -120,17 +137,30 @@ -- to be updated in an executable using e.g. 'buildLorentzDocWithGitRev'. contractGeneralDefault :: s :-> s contractGeneralDefault = - (contractGeneral $ doc DGitRevisionUnknown) # + (docGroup DGeneralInfoSection $ + doc DGitRevisionUnknown + ) # doc (DToc "") # doc DConversionInfo +instance ContainsDoc (i :-> o) where + buildDocUnfinalized = buildDocUnfinalized . iAnyCode +instance ContainsUpdateableDoc (i :-> o) where + modifyDocEntirely how = iMapAnyCode $ modifyDocEntirely how + +{-# DEPRECATED buildLorentzDocWithGitRev + "Use `buildDoc . attachDocCommons gitRev` instead." +#-} buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc -buildLorentzDocWithGitRev gitRev (iAnyCode -> code) = - buildInstrDocWithGitRev gitRev code +buildLorentzDocWithGitRev gitRev = buildDoc . attachDocCommons gitRev +{-# DEPRECATED renderLorentzDoc "Use 'buildMarkdownDoc' instead." #-} renderLorentzDoc :: inp :-> out -> LText -renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc +renderLorentzDoc = buildMarkdownDoc . finalizedAsIs +{-# DEPRECATED renderLorentzDocWithGitRev + "Use `buildMarkdownDoc . attachDocCommons gitRev` instead." +#-} renderLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> LText renderLorentzDocWithGitRev gitRev = contractDocToMarkdown . buildLorentzDocWithGitRev gitRev 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 @@ -34,6 +34,7 @@ , entryCase , entryCase_ , finalizeParamCallingDoc + , finalizeParamCallingDoc' , areFinalizedParamBuildingSteps , entryCaseSimple_ , entryCaseSimple @@ -64,7 +65,6 @@ import Michelson.Printer (printUntypedValue) import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB) import Michelson.Typed (pattern DefEpName, EpName, mkUType, sampleValueFromUntype) -import Michelson.Typed.Doc import Michelson.Typed.Haskell.Doc import Michelson.Typed.Haskell.Instr import qualified Michelson.Untyped as Untyped @@ -169,7 +169,7 @@ :: EntrypointKindHasDoc kind => Text -> Proxy kind -> (i :-> o) -> (i :-> o) entrypointSection name (_ :: Proxy kind) = - docGroup (SomeDocItem . DEntrypoint @kind name) + docGroup (DEntrypoint @kind name) -- | Default value for 'DEntrypoint' type argument. data PlainEntrypointsKind @@ -355,8 +355,7 @@ -> (inp :-> out) -> (inp :-> out) modifyParamBuildingSteps f = - iMapAnyCode $ - modifyInstrDoc (\di -> Just di{ epaBuilding = f (epaBuilding di) }) + modifyDoc (\di -> Just di{ epaBuilding = f (epaBuilding di) }) -- | Go over contract code and update every occurrence of 'DEntrypointArg' -- documentation item, adding the given step to its "how to build parameter" @@ -498,7 +497,7 @@ psteps = mkPbsWrapIn entrypointName michDesc addDoc instr = clarifyParamBuildingSteps psteps $ - docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $ + docGroup (DEntrypoint @kind entrypointName) $ doc (deriveCtorFieldDoc @ctor @cf) # instr in CaseClauseL (addDoc clause) :& RNil @@ -544,7 +543,7 @@ => param : s :-> out -> param : s :-> out documentEntrypoint instr = let entrypointName = toText $ symbolVal (Proxy @epName) in - docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $ + docGroup (DEntrypoint @kind entrypointName) $ doc (constructDEpArg @param) # instr -- | Provides arror for convenient entrypoint documentation @@ -574,18 +573,14 @@ -- -- Calling this twice over the same code is also prohibited. -- --- In simple contracts you may prefer using 'entryCaseSimple'. -finalizeParamCallingDoc +-- This method is for internal use, if you want to apply it to a contract +-- manually, use 'finalizeParamCallingDoc'. +finalizeParamCallingDoc' :: forall cp inp out. - (NiceParameterFull cp, RequireSumType cp, HasCallStack) - => (cp : inp :-> out) -> (cp : inp :-> out) -finalizeParamCallingDoc = modifyParamBuildingSteps modifySteps + (NiceParameterFull cp, HasCallStack) + => Proxy cp -> (inp :-> out) -> (inp :-> out) +finalizeParamCallingDoc' _ = modifyParamBuildingSteps modifySteps where - -- We do not actually need it, requiring this constraint only to avoid - -- misapplication of our function. - _needSumType :: Dict (RequireSumType cp) - _needSumType = Dict - epDescs :: [Some1 EpCallingDesc] epDescs = -- Reversing the list because if element @e1@ of this list is prefix of @@ -627,6 +622,19 @@ in Just $ callEpStep : truncated | otherwise = Nothing +-- | Version of 'finalizeParamCallingDoc\'' more convenient for manual call in +-- a contract. +finalizeParamCallingDoc + :: forall cp inp out. + (NiceParameterFull cp, RequireSumType cp, HasCallStack) + => (cp : inp :-> out) -> (cp : inp :-> out) +finalizeParamCallingDoc = finalizeParamCallingDoc' (Proxy @cp) + where + -- We do not actually need it, requiring this constraint only to avoid + -- misapplication of our function. + _needSumType :: Dict (RequireSumType cp) + _needSumType = Dict + -- | Whether 'finalizeParamCallingDoc' has already been applied to these steps. areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool areFinalizedParamBuildingSteps = @@ -648,25 +656,21 @@ ( InstrCaseC cp , RMap (CaseClauses cp) , DocumentEntrypoints PlainEntrypointsKind cp - , NiceParameterFull cp , RequireFlatParamEps cp ) => Rec (CaseClauseL inp out) (CaseClauses cp) -> cp : inp :-> out entryCaseSimple_ = - finalizeParamCallingDoc . entryCase_ (Proxy @PlainEntrypointsKind) + entryCase_ (Proxy @PlainEntrypointsKind) 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. --- --- This method calls 'finalizeParamCallingDoc' inside. entryCaseSimple :: forall cp out inp clauses. ( CaseTC cp out inp clauses , DocumentEntrypoints PlainEntrypointsKind cp - , NiceParameterFull cp , RequireFlatParamEps cp ) => IsoRecTuple clauses -> cp : inp :-> out @@ -674,7 +678,8 @@ type family RequireFlatParamEps cp :: Constraint where RequireFlatParamEps cp = - ( RequireFlatEpDerivation cp (GetParameterEpDerivation cp) + ( NiceParameterFull cp + , RequireFlatEpDerivation cp (GetParameterEpDerivation cp) , RequireSumType cp ) 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 @@ -121,7 +121,7 @@ -> inp :-> out -> inp :-> out applyErrorTagToErrorsDocWith handlers errorTagMap = - iMapAnyCode $ modifyInstrDoc @_ @DThrows $ + modifyDoc @_ @DThrows $ \(DThrows ep) -> flip runCont id $ callCC $ \quitWith -> do diff --git a/src/Lorentz/Macro.hs b/src/Lorentz/Macro.hs --- a/src/Lorentz/Macro.hs +++ b/src/Lorentz/Macro.hs @@ -658,11 +658,11 @@ typeDocMdReference = poly2TypeDocMdReference typeDocDependencies p = genericTypeDocDependencies p <> - [dTypeDep @(), dTypeDep @Integer] + [dTypeDep @MText, dTypeDep @Integer] typeDocHaskellRep = - haskellRepNoFields $ concreteTypeDocHaskellRep @(View () Integer) + haskellRepNoFields $ concreteTypeDocHaskellRep @(View MText Integer) typeDocMichelsonRep = - concreteTypeDocMichelsonRep @(View () Integer) + concreteTypeDocMichelsonRep @(View MText Integer) instance {-# OVERLAPPABLE #-} (Buildable a, WellTypedIsoValue r) => Buildable (View a r) where build = buildView build @@ -730,16 +730,20 @@ ("Void", DType tp) [ DType (Proxy @a) , DType (Proxy @r) + + -- for examples + , DType (Proxy @MText) + , DType (Proxy @Integer) ] typeDocDependencies p = genericTypeDocDependencies p <> [dTypeDep @(), dTypeDep @Integer] typeDocHaskellRep p descr = do - (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ () Integer)) p descr - return (Just "Void () Integer", rhs) + (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ MText Integer)) p descr + return (Just "Void MText Integer", rhs) typeDocMichelsonRep p = - let (_, rhs) = concreteTypeDocMichelsonRep @(Void_ () Integer) p - in (Just "Void () Integer", rhs) + let (_, rhs) = concreteTypeDocMichelsonRep @(Void_ MText Integer) p + in (Just "Void MText Integer", rhs) instance Buildable a => Buildable (Void_ a b) where build Void_ {..} = "(Void param: " +| voidParam |+ ")" diff --git a/src/Lorentz/Rebinded.hs b/src/Lorentz/Rebinded.hs --- a/src/Lorentz/Rebinded.hs +++ b/src/Lorentz/Rebinded.hs @@ -28,6 +28,7 @@ , fromInteger , fromString , fromLabel + , negate ) where diff --git a/src/Lorentz/Run.hs b/src/Lorentz/Run.hs --- a/src/Lorentz/Run.hs +++ b/src/Lorentz/Run.hs @@ -5,6 +5,10 @@ module Lorentz.Run ( CompilationOptions(..) , defaultCompilationOptions + , intactCompilationOptions + , coBytesTransformerL + , coOptimizerConfL + , coStringTransformerL , compileLorentz , compileLorentzWithOptions @@ -12,6 +16,9 @@ , Contract(..) , defaultContract , compileLorentzContract + , cCodeL + , cDisableInitialCastL + , cCompilationOptionsL , interpretLorentzInstr , interpretLorentzLambda @@ -26,7 +33,9 @@ import Lorentz.Annotation import Lorentz.Base import Lorentz.Constraints +import Lorentz.Doc import Lorentz.Entrypoints +import Lorentz.Entrypoints.Doc import Michelson.Analyzer (AnalyzerRes, analyze) import Michelson.Interpret import Michelson.Optimizer (OptimizerConf, optimizeWithConf) @@ -34,6 +43,7 @@ import Michelson.Typed (Instr(..), IsoValue, IsoValuesStack(..), ToT, ToTs, starParamNotes) import qualified Michelson.Typed as M (Contract(..)) import qualified Michelson.Untyped as U (canonicalEntriesOrder) +import Util.Lens -- | Options to control Lorentz to Michelson compilation. data CompilationOptions = CompilationOptions @@ -53,6 +63,14 @@ , coBytesTransformer = (False, id) } +-- | Leave contract without any modifications. For testing purposes. +intactCompilationOptions :: CompilationOptions +intactCompilationOptions = CompilationOptions + { coOptimizerConf = Nothing + , coStringTransformer = (False, id) + , coBytesTransformer = (False, id) + } + -- | For use outside of Lorentz. Will use 'defaultCompilationOptions'. compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out) compileLorentz = compileLorentzWithOptions defaultCompilationOptions @@ -88,9 +106,11 @@ } -- | Compile contract with 'defaultCompilationOptions' and 'cDisableInitialCast' set to @False@. -defaultContract :: ContractCode cp st -> Contract cp st +defaultContract + :: forall cp st. (NiceParameterFull cp, HasCallStack) + => ContractCode cp st -> Contract cp st defaultContract code = Contract - { cCode = code + { cCode = finalizeParamCallingDoc' (Proxy @cp) code , cDisableInitialCast = False , cCompilationOptions = defaultCompilationOptions } @@ -144,6 +164,16 @@ let Identity out :& RNil = res return out +instance ContainsDoc (Contract cp st) where + buildDocUnfinalized = + buildDocUnfinalized . cCode +instance ContainsUpdateableDoc (Contract cp st) where + modifyDocEntirely how c = + c{ cCode = modifyDocEntirely how (cCode c) } + -- | Lorentz version of analyzer. analyzeLorentz :: inp :-> out -> AnalyzerRes analyzeLorentz = analyze . compileLorentz + +makeLensesWith postfixLFields ''CompilationOptions +makeLensesWith postfixLFields ''Contract diff --git a/src/Lorentz/Value.hs b/src/Lorentz/Value.hs --- a/src/Lorentz/Value.hs +++ b/src/Lorentz/Value.hs @@ -59,6 +59,7 @@ , convertContractRef -- * Misc + , Show , Default (..) , Label (..) , PrintAsValue (..) @@ -76,6 +77,7 @@ import Michelson.Text import Michelson.Typed (EntrypointCall, IsoValue(..), SomeEntrypointCall, Value, WellTypedIsoValue) import qualified Michelson.Typed as M +import Michelson.Typed.Haskell.Compatibility as ReExports import Tezos.Core (ChainId, Mutez, Timestamp, oneMutez, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez, zeroMutez)