morley 0.3.0.1 → 0.4.0

raw patch · 189 files changed

+18836/−3945 lines, 189 filesdep +bimapdep +first-class-familiesdep +gitrevdep −generic-arbitrarydep −qm-interpolated-stringdep ~constraintsdep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: bimap, first-class-families, gitrev, interpolate, pretty-terminal, show-type, spoon, tasty-hunit, unordered-containers

Dependencies removed: generic-arbitrary, qm-interpolated-string

Dependency ranges changed: constraints, megaparsec

API changes (from Hackage documentation)

Files

• CHANGES.md +17/−0
• CONTRIBUTING.md +7/−8
• README.md +22/−11
• app/Main.hs +83/−25
• contract-discover/Main.hs +0/−155
• morley.cabal +96/−35
• src/Lorentz.hs +13/−1
• src/Lorentz/ADT.hs +56/−25
• src/Lorentz/Arith.hs +15/−18
• src/Lorentz/Base.hs +129/−33
• src/Lorentz/Coercions.hs +27/−0
• src/Lorentz/Common.hs +17/−0
• src/Lorentz/Constraints.hs +81/−6
• src/Lorentz/Discover.hs +0/−118
• src/Lorentz/Doc.hs +133/−0
• src/Lorentz/EntryPoints.hs +349/−0
• src/Lorentz/EntryPoints/Doc.hs +209/−0
• src/Lorentz/Errors.hs +655/−39
• src/Lorentz/Errors/Common.hs +28/−0
• src/Lorentz/Errors/Numeric.hs +139/−0
• src/Lorentz/Ext.hs +6/−4
• src/Lorentz/Extensible.hs +268/−0
• src/Lorentz/Instr.hs +216/−76
• src/Lorentz/Macro.hs +294/−139
• src/Lorentz/Pack.hs +26/−0
• src/Lorentz/Prelude.hs +5/−0
• src/Lorentz/Print.hs +34/−0
• src/Lorentz/Rebinded.hs +6/−6
• src/Lorentz/Referenced.hs +1/−6
• src/Lorentz/Run.hs +77/−0
• src/Lorentz/Store.hs +119/−45
• src/Lorentz/StoreClass.hs +351/−0
• src/Lorentz/Test.hs +17/−1
• src/Lorentz/Test/Consumer.hs +14/−0
• src/Lorentz/Test/Integrational.hs +156/−54
• src/Lorentz/TestScenario.hs +54/−0
• src/Lorentz/UParam.hs +390/−0
• src/Lorentz/UStore.hs +92/−0
• src/Lorentz/UStore/Common.hs +13/−0
• src/Lorentz/UStore/Haskell.hs +335/−0
• src/Lorentz/UStore/Instances.hs +24/−0
• src/Lorentz/UStore/Instr.hs +353/−0
• src/Lorentz/UStore/Lift.hs +112/−0
• src/Lorentz/UStore/Migration.hs +89/−0
• src/Lorentz/UStore/Migration/Base.hs +460/−0
• src/Lorentz/UStore/Migration/Batching.hs +113/−0
• src/Lorentz/UStore/Migration/Blocks.hs +287/−0
• src/Lorentz/UStore/Migration/Diff.hs +196/−0
• src/Lorentz/UStore/Types.hs +261/−0
• src/Lorentz/Value.hs +116/−3
• src/Lorentz/Zip.hs +82/−0
• src/Michelson/Analyzer.hs +116/−0
• src/Michelson/Doc.hs +481/−0
• src/Michelson/EqParam.hs +0/−66
• src/Michelson/FailPattern.hs +118/−0
• src/Michelson/Interpret.hs +219/−91
• src/Michelson/Interpret/Pack.hs +85/−30
• src/Michelson/Interpret/Unpack.hs +216/−118
• src/Michelson/Macro.hs +97/−49
• src/Michelson/OpSize.hs +241/−0
• src/Michelson/Optimizer.hs +296/−0
• src/Michelson/Parser.hs +29/−13
• src/Michelson/Parser/Error.hs +17/−4
• src/Michelson/Parser/Ext.hs +2/−3
• src/Michelson/Parser/Helpers.hs +16/−1
• src/Michelson/Parser/Instr.hs +44/−19
• src/Michelson/Parser/Let.hs +7/−12
• src/Michelson/Parser/Macro.hs +27/−5
• src/Michelson/Parser/Type.hs +71/−98
• src/Michelson/Parser/Value.hs +5/−2
• src/Michelson/Preprocess.hs +77/−0
• src/Michelson/Printer.hs +27/−5
• src/Michelson/Printer/Util.hs +70/−15
• src/Michelson/Runtime.hs +109/−73
• src/Michelson/Runtime/GState.hs +87/−24
• src/Michelson/Test.hs +9/−0
• src/Michelson/Test/Dummy.hs +4/−5
• src/Michelson/Test/Gen.hs +1/−1
• src/Michelson/Test/Import.hs +94/−12
• src/Michelson/Test/Integrational.hs +143/−26
• src/Michelson/Text.hs +35/−3
• src/Michelson/TypeCheck.hs +1/−0
• src/Michelson/TypeCheck/Error.hs +63/−15
• src/Michelson/TypeCheck/Ext.hs +17/−12
• src/Michelson/TypeCheck/Helpers.hs +51/−56
• src/Michelson/TypeCheck/Instr.hs +380/−192
• src/Michelson/TypeCheck/TypeCheck.hs +17/−6
• src/Michelson/TypeCheck/Types.hs +25/−15
• src/Michelson/TypeCheck/Value.hs +87/−59
• src/Michelson/Typed.hs +3/−1
• src/Michelson/Typed/Aliases.hs +4/−0
• src/Michelson/Typed/Annotation.hs +65/−111
• src/Michelson/Typed/Arith.hs +36/−36
• src/Michelson/Typed/CValue.hs +2/−2
• src/Michelson/Typed/Convert.hs +250/−109
• src/Michelson/Typed/Doc.hs +109/−0
• src/Michelson/Typed/EntryPoints.hs +424/−0
• src/Michelson/Typed/Extract.hs +93/−153
• src/Michelson/Typed/Haskell.hs +2/−0
• src/Michelson/Typed/Haskell/Doc.hs +797/−0
• src/Michelson/Typed/Haskell/Instr/Helpers.hs +0/−16
• src/Michelson/Typed/Haskell/Instr/Product.hs +1/−0
• src/Michelson/Typed/Haskell/Instr/Sum.hs +72/−43
• src/Michelson/Typed/Haskell/LooseSum.hs +127/−0
• src/Michelson/Typed/Haskell/Value.hs +127/−22
• src/Michelson/Typed/Instr.hs +181/−28
• src/Michelson/Typed/Print.hs +0/−21
• src/Michelson/Typed/Scope.hs +373/−125
• src/Michelson/Typed/Sing.hs +5/−0
• src/Michelson/Typed/T.hs +40/−1
• src/Michelson/Typed/Util.hs +415/−0
• src/Michelson/Typed/Value.hs +116/−41
• src/Michelson/Untyped/Annotation.hs +25/−43
• src/Michelson/Untyped/Contract.hs +5/−4
• src/Michelson/Untyped/Ext.hs +2/−2
• src/Michelson/Untyped/Instr.hs +136/−122
• src/Michelson/Untyped/Type.hs +145/−70
• src/Michelson/Untyped/Value.hs +26/−10
• src/Tezos/Address.hs +57/−11
• src/Tezos/Core.hs +159/−4
• src/Tezos/Crypto.hs +264/−213
• src/Tezos/Crypto/Ed25519.hs +172/−0
• src/Tezos/Crypto/Hash.hs +35/−0
• src/Tezos/Crypto/P256.hs +173/−0
• src/Tezos/Crypto/Secp256k1.hs +233/−0
• src/Tezos/Crypto/Util.hs +113/−0
• src/Util/Generic.hs +18/−3
• src/Util/IO.hs +5/−0
• src/Util/Instances.hs +4/−0
• src/Util/Lens.hs +8/−1
• src/Util/Markdown.hs +114/−0
• src/Util/Named.hs +34/−6
• src/Util/Peano.hs +103/−31
• src/Util/Positive.hs +36/−0
• src/Util/Test/Arbitrary.hs +16/−8
• src/Util/Text.hs +14/−0
• src/Util/Type.hs +111/−1
• src/Util/TypeLits.hs +46/−0
• src/Util/TypeTuple/Instances.hs +1/−1
• src/Util/Typeable.hs +109/−0
• test/Test/Analyzer.hs +53/−0
• test/Test/Doc.hs +158/−0
• test/Test/EntryPoints.hs +93/−0
• test/Test/Ext.hs +17/−17
• test/Test/Integrational.hs +26/−0
• test/Test/Interpreter.hs +347/−127
• test/Test/Interpreter/A1/Feather.hs +0/−237
• test/Test/Interpreter/Auction.hs +131/−0
• test/Test/Interpreter/CallSelf.hs +21/−18
• test/Test/Interpreter/Compare.hs +13/−13
• test/Test/Interpreter/Conditionals.hs +13/−13
• test/Test/Interpreter/ContractOp.hs +17/−17
• test/Test/Interpreter/EnvironmentSpec.hs +27/−17
• test/Test/Interpreter/StringCaller.hs +24/−22
• test/Test/Lorentz/Base.hs +29/−0
• test/Test/Lorentz/DeadCode.hs +45/−0
• test/Test/Lorentz/Discovery.hs +0/−114
• test/Test/Lorentz/EntryPoints.hs +291/−0
• test/Test/Lorentz/Errors.hs +140/−0
• test/Test/Lorentz/Extensible.hs +71/−0
• test/Test/Lorentz/Macro.hs +29/−16
• test/Test/Lorentz/Print.hs +40/−0
• test/Test/Lorentz/UParam.hs +98/−0
• test/Test/Lorentz/UStore/Behaviour.hs +177/−0
• test/Test/Lorentz/UStore/Migration/Batched.hs +76/−0
• test/Test/Lorentz/UStore/Migration/Batched/V1.hs +15/−0
• test/Test/Lorentz/UStore/Migration/Batched/V2.hs +12/−0
• test/Test/Lorentz/UStore/Migration/FillInParts.hs +84/−0
• test/Test/Lorentz/UStore/Migration/Simple.hs +82/−0
• test/Test/Lorentz/UStore/Migration/Simple/V1.hs +13/−0
• test/Test/Lorentz/UStore/Migration/Simple/V2.hs +13/−0
• test/Test/Lorentz/UStore/SafeLift.hs +42/−0
• test/Test/Lorentz/UStore/SafeLift/Helpers.hs +14/−0
• test/Test/Macro.hs +1/−2
• test/Test/Michelson/Runtime.hs +67/−12
• test/Test/Michelson/Typed/Util.hs +34/−0
• test/Test/OpSize.hs +251/−0
• test/Test/Optimizer.hs +123/−0
• test/Test/Parser.hs +62/−31
• test/Test/Preprocess.hs +58/−0
• test/Test/Printer/Michelson.hs +81/−8
• test/Test/Serialization/Michelson.hs +248/−124
• test/Test/Tezos/Address.hs +9/−0
• test/Test/Tezos/Core.hs +76/−0
• test/Test/Tezos/Crypto.hs +70/−45
• test/Test/Tezos/Crypto/Hash.hs +48/−0
• test/Test/Typecheck.hs +25/−32
• test/Test/Util/Contracts.hs +25/−3
• test/Test/Util/HUnit.hs +14/−0

@@ -1,3 +1,20 @@+0.4.0+=====++* Implemented most of Babylon changes: new instructions, elimination of `big_map` restructions, new restrictions for the `contract` type, partial support for entrypoints. Some instructions have been removed/deprecated.+* Many updates of helper data types for upgradeable contracts: `UParam` and `UStore`.+* Michelson printer can produce pretty output, not just one line.+* Added utilities for contract processing and analysis: optimizer, string transformer, errors transformer, analyzer.+* Added `tasty` helpers to the testing engine.+* Added annotations to typed representation and Lorentz.+* Added automatic documentation generator.+* Modified standard errors in Lorentz: now they are based on `CustomError`.+* Added unpacking from readable representation.+* Removed `parameter` and `storage` aliases, they were not very useful and complicated the code.+* Extended cryptographic types and `Address` to work with other curves (tz2 and tz3 addresses).+* Made it nearly impossible to generate dead code (which is illegal in Michelson) using Lorentz.+* Various bug fixes.+ 0.3.0.1 ======= 

@@ -2,13 +2,12 @@  ## Reporting Issues -Please [open an issue](https://issues.serokell.io/newIssue?project=TM)+Please [open an issue](https://gitlab.com/morley-framework/morley/issues/new) if you find a bug or have a feature request.-Note: you need to login (e. g. using your GitHub account) first. Before submitting a bug report or feature request, check to make sure it hasn't already been submitted.  The more detailed your report is, the faster it can be resolved.-If you report a bug, please provide steps to reproduce this bug and revision of code in which this bug reproduces.+Please use issue templates to create an issue.  ## Code @@ -46,7 +45,7 @@ common developers' activities, like building with flags suitable for development, testing, applying `stylish-haskell` and `hlint`, building Haddock documentation. Mentioned `Makefile` builds morley itself,-each extra package, like [`lorentz-contracts`](/lorentz-contracts/Makefile),+each extra package, like [`morley-ledgers`](/morley-ledgers/Makefile), has its own `Makefile`.  If you want to run test suite with additional options, set `TEST_ARGUMENTS` variable.@@ -64,11 +63,11 @@  As soon as this repository uses different default extensions in different packages, Intero may report non-existing errors.-This issue [is known](https://github.com/chrisdone/intero/issues/554) and probably-won't be resolved soon.+This issue is known (once located under https://github.com/chrisdone/intero/issues/554)+and will never be resolved unless `intero` project is resurrected.  However, with proper care, this problem can be avoided. Just follow the rules: * When working with `morley` package, select only `morley:*` packages in `intero-targets`.-* When developing on Lorentz within `lorentz-contracts` package, make sure that+* When developing on Lorentz within e. g. `morley-ledgers` package, make sure that you first built morley core with `make morley`, only after that open the Lorentz modules.-Then set `lorentz-contracts:*` packages as intero targets.+Then set `morley-ledgers:*` packages as intero targets.

@@ -5,11 +5,6 @@ Morley is a library to make writing smart contracts in Michelson pleasant and effective. -## ZuriHac notice--Morley is one of the projects at [ZuriHac 2019](https://zfoh.ch/zurihac2019/).-If you want to participate, please go to https://morley-zurihac.serokell.io/ to get more information.- ## I: A reimplementation of the Michelson Language in Haskell  It consists of the following parts:@@ -50,9 +45,10 @@ Later Lorentz contract can be dumped as a plain textual Michelson contract using functions from [`Michelson.Printer`](/src/Michelson/Printer.hs).  You can find Lorentz instructions in [`Lorentz`](/src/Lorentz.hs) modules.-Examples reside in [`Lorentz.Contracts.*`](/lorentz-contracts/src/Lorentz/Contracts/) modules.-For more information, refer this package [README](/lorentz-contracts/README.md). +Examples of using Lorentz eDSL reside in the [`morley-ledgers`](/morley-ledgers) package.+For more information, refer to this package [README](/morley-ledgers/README.md).+ ## V: Testing EDSL  Another way to test Michelson contracts is to write tests in Haskell using the testing EDSL provided by Morley.@@ -85,17 +81,32 @@     after that you can do `stack exec -- morley <args>` to run morley executable built from the source code.   * Usage example:     + `stack exec -- morley --help` to see help message-    + `stack exec -- morley originate --contract contracts/add1.tz --storage 1 --verbose`+    + `stack exec -- morley originate --contract contracts/tezos_examples/attic/add1.tz --storage 1 --verbose`+- [Cabal](https://www.haskell.org/cabal/) based.+  * Clone this git repository and run `cabal new-update && cabal new-build` command,+    after that you can do `cabal run -- morley <args>` to run morley executable built from the source code.+  * Usage example:+    + `cabal run -- morley --help` to see help message+    + `cabal run -- morley originate --contract contracts/tezos_examples/attic/add1.tz --storage 1 --verbose`  For more information about Morley commands, check out the following docs: - [Interpreter doc](/docs/morleyInterpreter.md) - [Typechecker doc](/docs/morleyTypechecker.md) +## Michelson version++`master` and `production` branches are maintained to be compatible with version of Michelson running on mainnet.+We use separate branches to support other versions.+More information about our branching strategy can be found [here](/docs/branching.md).+ ## Issue Tracker -We use [YouTrack](https://issues.serokell.io/issues/TM) as our issue-tracker. You can login using your GitHub account to leave a comment or-create a new issue.+We used to use [YouTrack](https://issues.serokell.io/issues/TM) as our primary issue tracker.+You may see that commit messages up to some date are prefixed with `[TM-X]`.+This prefix refers to an issue in our YouTrack.+YouTrack issues are public, so you can open any of them.++Nowadays we are using built-in issue tracker on GitLab.  ## For Contributors 

@@ -5,7 +5,7 @@ import qualified Control.Exception as E import Data.Version (showVersion) import Fmt (pretty)-import Named ((:?), argF, (!))+import Named ((:!), (:?), arg, argF, (!)) import Options.Applicative   (auto, command, eitherReader, execParser, footerDoc, fullDesc, header, help, helper, info,   infoOption, long, maybeReader, metavar, option, progDesc, readerError, short, showDefault,@@ -18,13 +18,17 @@ import Text.Pretty.Simple (pPrint) import qualified Text.Show -import Michelson.Macro (expandContract, expandValue)+import Michelson.Analyzer (analyze)+import Michelson.Macro (expandContract)+import Michelson.Optimizer (optimize) import qualified Michelson.Parser as P-import Michelson.Printer (printUntypedContract)+import Michelson.Printer (printSomeContract, printUntypedContract) import Michelson.Runtime   (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer,   typeCheckWithDb)-import Michelson.Runtime.GState (genesisAddress, genesisKeyHash)+import Michelson.Runtime.GState (genesisAddress)+import Michelson.TypeCheck.Types (SomeContract(..), mapSomeContract)+import Michelson.Typed (FullContract(..)) import Michelson.Untyped hiding (OriginationOperation(..)) import qualified Michelson.Untyped as U import Tezos.Address (Address, parseAddress)@@ -40,12 +44,26 @@  data CmdLnArgs   = Parse (Maybe FilePath) Bool-  | Print ("input" :? FilePath) ("output" :? FilePath)+  | Print ("input" :? FilePath) ("output" :? FilePath) ("singleLine" :! Bool)+  | Optimize !OptimizeOptions+  | Analyze !AnalyzeOptions   | TypeCheck !TypeCheckOptions   | Run !RunOptions   | Originate !OriginateOptions   | Transfer !TransferOptions +data OptimizeOptions = OptimizeOptions+  { optoContractFile :: !(Maybe FilePath)+  , optoDBPath :: !FilePath+  , optoOutput :: !(Maybe FilePath)+  , optoSingleLine :: !Bool+  }++data AnalyzeOptions = AnalyzeOptions+  { aoContractFile :: !(Maybe FilePath)+  , aoDBPath :: !FilePath+  }+ data TypeCheckOptions = TypeCheckOptions   { tcoContractFile :: !(Maybe FilePath)   , tcoDBPath       :: !FilePath@@ -62,15 +80,14 @@   , roMaxSteps :: !Word64   , roInitBalance :: !Mutez   , roWrite :: !Bool+    -- TODO [TM-280]: add `--entrypoint` option   }  data OriginateOptions = OriginateOptions   { ooContractFile :: !(Maybe FilePath)   , ooDBPath :: !FilePath-  , ooManager :: !KeyHash+  , ooOriginator :: !Address   , ooDelegate :: !(Maybe KeyHash)-  , ooSpendable :: !Bool-  , ooDelegatable :: !Bool   , ooStorageValue :: !U.Value   , ooBalance :: !Mutez   , ooVerbose :: !Bool@@ -93,7 +110,9 @@   typecheckSubCmd <>   runSubCmd <>   originateSubCmd <>-  transferSubCmd+  transferSubCmd <>+  optimizeSubCmd <>+  analyzeSubCmd   where     mkCommandParser commandName parser desc =       command commandName $@@ -112,7 +131,9 @@      printSubCmd =       mkCommandParser "print"-      (Print <$> (#input <.?> contractFileOption) <*> (#output <.?> outputOption))+      (Print <$> (#input <.?> contractFileOption)+             <*> (#output <.?> outputOption)+             <*> (#singleLine <.!> onelineOption))       ("Parse a Morley contract and print corresponding Michelson " <>        "contract that can be parsed by the OCaml reference client") @@ -132,6 +153,16 @@       (Transfer <$> transferOptions)       "Transfer tokens to given address" +    optimizeSubCmd =+      mkCommandParser "optimize"+      (Optimize <$> optimizeOptions)+      "Optimize the contract."++    analyzeSubCmd =+      mkCommandParser "analyze"+      (Analyze <$> analyzeOptions)+      "Analyze the contract."+     verboseFlag :: Opt.Parser Bool     verboseFlag = switch $       short 'v' <>@@ -164,6 +195,18 @@     defaultBalance :: Mutez     defaultBalance = unsafeMkMutez 4000000 +    optimizeOptions :: Opt.Parser OptimizeOptions+    optimizeOptions = OptimizeOptions+      <$> contractFileOption+      <*> dbPathOption+      <*> outputOption+      <*> onelineOption++    analyzeOptions :: Opt.Parser AnalyzeOptions+    analyzeOptions = AnalyzeOptions+      <$> contractFileOption+      <*> dbPathOption+     runOptions :: Opt.Parser RunOptions     runOptions =       RunOptions@@ -183,13 +226,9 @@       OriginateOptions         <$> contractFileOption         <*> dbPathOption-        <*> keyHashOption (Just genesisKeyHash) "manager" "Contract's manager"+        <*> addressOption (Just genesisAddress) "originator" "Contract's originator"         <*> optional             (keyHashOption Nothing "delegate" "Contract's optional delegate")-        <*> switch (long "spendable" <>-                    help "Whether the contract is spendable")-        <*> switch (long "delegatable" <>-                    help "Whether the contract is delegatable")         <*> valueOption "storage" "Initial storage of an originating contract"         <*> mutezOption (Just defaultBalance)             "balance" "Initial balance of an originating contract"@@ -206,6 +245,7 @@       toDryRun <- dryRunFlag       pure TransferOptions {..} + contractFileOption :: Opt.Parser (Maybe FilePath) contractFileOption = optional $ strOption $   long "contract" <>@@ -219,7 +259,7 @@   help "Timestamp that you want the runtime interpreter to use (default is now)"   where     parser =-      (timestampFromSeconds @Integer <$> auto) <|>+      (timestampFromSeconds <$> auto) <|>       maybeReader (parseTimestamp . toText)  maxStepsOption :: Opt.Parser Word64@@ -251,10 +291,10 @@   help hInfo   where     parseValue :: String -> Either String U.Value-    parseValue s =-      either (Left . mappend "Failed to parse value: " . show)-             (Right . expandValue)-      $ P.parseNoEnv P.value "" (toText s)+    parseValue =+      first (mappend "Failed to parse value: " . displayException) .+      P.parseExpandValue .+      toText  mutezOption :: Maybe Mutez -> String -> String -> Opt.Parser Mutez mutezOption defaultValue name hInfo =@@ -277,6 +317,11 @@       either (Left . mappend "Failed to parse address: " . pretty) Right $       parseAddress $ toText addr +onelineOption :: Opt.Parser Bool+onelineOption = switch (+  long "oneline" <>+  help "Force single line output")+ outputOption :: Opt.Parser (Maybe FilePath) outputOption = optional . strOption $   short 'o' <>@@ -372,10 +417,24 @@         if hasExpandMacros           then pPrint $ expandContract contract           else pPrint contract-      Print (argF #input -> mInputFile) (argF #output -> mOutputFile) -> do+      Print (argF #input -> mInputFile)+            (argF #output -> mOutputFile)+            (arg #singleLine -> forceSingleLine) -> do         contract <- prepareContract mInputFile         let write = maybe putStrLn writeFileUtf8 mOutputFile-        write $ printUntypedContract contract+        write $ printUntypedContract forceSingleLine contract+      Optimize OptimizeOptions{..} -> do+        untypedContract <- prepareContract optoContractFile+        checkedContract <- either throwM pure =<<+          typeCheckWithDb optoDBPath untypedContract+        let optimizedContract = mapSomeContract optimize checkedContract+        let write = maybe putStrLn writeFileUtf8 optoOutput+        write $ printSomeContract optoSingleLine optimizedContract+      Analyze AnalyzeOptions{..} -> do+        untypedContract <- prepareContract aoContractFile+        SomeContract contract <- either throwM pure =<<+          typeCheckWithDb aoDBPath untypedContract+        putTextLn $ pretty $ analyze (fcCode contract)       TypeCheck TypeCheckOptions{..} -> do         morleyContract <- prepareContract tcoContractFile         either throwM (const pass) =<< typeCheckWithDb tcoDBPath morleyContract@@ -388,10 +447,8 @@       Originate OriginateOptions {..} -> do         michelsonContract <- prepareContract ooContractFile         let origination = U.OriginationOperation-              { U.ooManager = ooManager+              { U.ooOriginator = ooOriginator               , U.ooDelegate = ooDelegate-              , U.ooSpendable = ooSpendable-              , U.ooDelegatable = ooDelegatable               , U.ooStorage = ooStorageValue               , U.ooBalance = ooBalance               , U.ooContract = michelsonContract@@ -402,6 +459,7 @@         transfer toNow toMaxSteps toDBPath toDestination toTxData           ! #verbose toVerbose           ! #dryRun toDryRun+  usageDoc :: Maybe Doc usageDoc = Just $ mconcat

@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}---- | An executable for haskell preprocessor which finds--- all contract declarations in Haskell modules within the directory where--- preprocessor is called and exports found contracts in a map.-module Main-  ( main-  ) where--import qualified Unsafe--import Data.Default (Default(..))-import Fmt (Builder, build, fmt, indentF, listF', unlinesF, (+|), (+||), (|+), (||+))-import qualified System.Directory as Dir-import System.Environment (getArgs)-import System.FilePath.Posix (isAbsolute, takeDirectory, (</>))-import Text.Megaparsec (errorBundlePretty, runParser)--import Lorentz.Discover-import Util.IO (hSetTranslit, readFileUtf8, writeFileUtf8)--main :: IO ()-main = do-  hSetTranslit stderr-  args <- getArgs-  case args of-    src : _ : dst : opts -> do-      Config{..} <- parseOpts def (map toText opts)--      let scanRoot-            | isAbsolute cScanRoot = cScanRoot-            | otherwise = takeDirectory src </> cScanRoot-      validRoot <- Dir.doesDirectoryExist scanRoot-      unless validRoot $-        die $ "Specified scan root is not an existing directory: " <> scanRoot-      contracts <- findContracts cDebug scanRoot--      verifyContractDecls contracts-      let output = fmt @Text $ unlinesF-            [ pragmasSection-            , "module " +| cModuleName |+ " (contracts) where"-            , ""-            , importsSection contracts-            , ""-            , contractsMapSection contracts-            ]-      printDebug cDebug . fmt $-        "Generated module:\n" +| indentF 2 (build output) |+ ""--      writeFileUtf8 dst output-    _ -> do-      die "Usage: lorentz-discover src _ dst moduleName"--newtype IsDebug = IsDebug Bool--data Config = Config-  { cModuleName :: Text-  , cDebug :: IsDebug-  , cScanRoot :: FilePath-  }--instance Default Config where-  def = Config-    { cModuleName = "Main"-    , cDebug = IsDebug False-    , cScanRoot = "."-    }--parseOpts :: Config -> [Text] -> IO Config-parseOpts cfg = \case-  [] -> pure cfg-  "--debug" : opts ->-    parseOpts cfg{ cDebug = IsDebug True } opts-  "--generated-module" : opts ->-    case opts of-      [] -> die "Usage: `--generated-module <module name>`"-      modName : os -> parseOpts cfg{ cModuleName = modName } os-  "--root" : opts ->-    case opts of-      [] -> die "Usage: `--root <directory>`"-      root : os -> parseOpts cfg{ cScanRoot = toString root } os-  opt : _ ->-    die $ "Unknown option: " <> show opt--printDebug :: IsDebug -> Text -> IO ()-printDebug (IsDebug isDebug)-  | isDebug = hPutStrLn stderr . ("contract-discover: " <>)-  | otherwise = \_ -> pass--findContracts :: IsDebug -> FilePath -> IO [ExportedContractInfo]-findContracts isDebug path = do-  isDir <- Dir.doesDirectoryExist path-  if isDir-    then do-      dirs <- Dir.listDirectory path-      concatMapM (findContracts isDebug) (map (path </>) dirs)-    else do-      if isHaskellModule path-        then parseHaskellModule isDebug path-        else pure []--parseHaskellModule :: IsDebug -> FilePath -> IO [ExportedContractInfo]-parseHaskellModule isDebug path = do-  file <- readFileUtf8 path-  case runParser haskellExportsParser path file of-    -- Some autogenerated modules may have no export list, we ignore them-    Left err -> do-      printDebug isDebug . toText $ errorBundlePretty err-      return []-    Right res -> do-      printDebug isDebug $ "In module " +|| path ||+ " found contracts "-                         +| listF' (build . ecdName . eciContractDecl) res |+ ""-      return res---- | Ensures that:------ 1. No two contracts have the same name.-verifyContractDecls :: [ExportedContractInfo] -> IO ()-verifyContractDecls contracts = do-  let vars = map (ecdVar . eciContractDecl) contracts-  let dups = map head . mapMaybe (nonEmpty . Unsafe.init) . group $ sort vars-  case dups of-    [] -> pass-    dup : _ -> die $ "Found multiple contracts with the same name: " <> show dup--pragmasSection :: Builder-pragmasSection =-  mconcat . map (<> "\n") $-  [ "{-# LANGUAGE ImplicitPrelude #-}"-  ]--importsSection :: [ExportedContractInfo] -> Builder-importsSection =-  mconcat . map (<> "\n") .-  (extraImports ++) . map mkImport . ordNub . map eciModuleName-  where-  mkImport m = "import qualified " +| m |+ ""-  extraImports =-    [ "import Data.Text (Text)"-    , "import qualified Data.Map as Map"--    , "import qualified Michelson.Untyped as U"-    , "import Lorentz.Discover"-    ]--contractsMapSection :: [ExportedContractInfo] -> Builder-contractsMapSection contracts =-  "contracts :: Map.Map Text U.Contract\n\-  \contracts = Map.fromList\n  " <> listF' contractPairF contracts-  where-    -- Forms @(contract name, contract variable)@ pair.-    contractPairF ExportedContractInfo{..} =-      let ExportedContractDecl{..} = eciContractDecl-          var = "toUntypedContract " +| eciModuleName |+ "." +| ecdVar |+ ""-      in "\n  (\"" +| ecdName |+ "\", " +| var +| ")"

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8457691bdf7fc43270f283f6722fc1c2dbc40a1cbc9cf90d3f2724657b6f62bf+-- hash: 341e0aff6cea56ed81fb3488e1f28073f9d4b8ee8f16cb92cd8da89994761071  name:           morley-version:        0.3.0.1+version:        0.4.0 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -35,27 +35,57 @@       Lorentz.Arith       Lorentz.Base       Lorentz.Coercions+      Lorentz.Common       Lorentz.Constraints-      Lorentz.Discover+      Lorentz.Doc+      Lorentz.EntryPoints+      Lorentz.EntryPoints.Doc       Lorentz.Errors+      Lorentz.Errors.Common+      Lorentz.Errors.Numeric       Lorentz.Ext+      Lorentz.Extensible       Lorentz.Instr       Lorentz.Macro+      Lorentz.Pack       Lorentz.Polymorphic       Lorentz.Prelude+      Lorentz.Print       Lorentz.Rebinded       Lorentz.Referenced+      Lorentz.Run       Lorentz.Store+      Lorentz.StoreClass       Lorentz.Test+      Lorentz.Test.Consumer       Lorentz.Test.Integrational+      Lorentz.TestScenario+      Lorentz.UParam+      Lorentz.UStore+      Lorentz.UStore.Common+      Lorentz.UStore.Haskell+      Lorentz.UStore.Instances+      Lorentz.UStore.Instr+      Lorentz.UStore.Lift+      Lorentz.UStore.Migration+      Lorentz.UStore.Migration.Base+      Lorentz.UStore.Migration.Batching+      Lorentz.UStore.Migration.Blocks+      Lorentz.UStore.Migration.Diff+      Lorentz.UStore.Types       Lorentz.Value-      Michelson.EqParam+      Lorentz.Zip+      Michelson.Analyzer+      Michelson.Doc       Michelson.ErrorPos+      Michelson.FailPattern       Michelson.Interpret       Michelson.Interpret.Pack       Michelson.Interpret.Unpack       Michelson.Let       Michelson.Macro+      Michelson.OpSize+      Michelson.Optimizer       Michelson.Parser       Michelson.Parser.Annotations       Michelson.Parser.Error@@ -68,6 +98,7 @@       Michelson.Parser.Type       Michelson.Parser.Types       Michelson.Parser.Value+      Michelson.Preprocess       Michelson.Printer       Michelson.Printer.Util       Michelson.Runtime@@ -95,19 +126,23 @@       Michelson.Typed.Arith       Michelson.Typed.Convert       Michelson.Typed.CValue+      Michelson.Typed.Doc+      Michelson.Typed.EntryPoints       Michelson.Typed.Extract       Michelson.Typed.Haskell+      Michelson.Typed.Haskell.Doc       Michelson.Typed.Haskell.Instr       Michelson.Typed.Haskell.Instr.Helpers       Michelson.Typed.Haskell.Instr.Product       Michelson.Typed.Haskell.Instr.Sum+      Michelson.Typed.Haskell.LooseSum       Michelson.Typed.Haskell.Value       Michelson.Typed.Instr       Michelson.Typed.Polymorphic-      Michelson.Typed.Print       Michelson.Typed.Scope       Michelson.Typed.Sing       Michelson.Typed.T+      Michelson.Typed.Util       Michelson.Typed.Value       Michelson.Untyped       Michelson.Untyped.Aliases@@ -120,17 +155,27 @@       Tezos.Address       Tezos.Core       Tezos.Crypto+      Tezos.Crypto.Ed25519+      Tezos.Crypto.Hash+      Tezos.Crypto.P256+      Tezos.Crypto.Secp256k1+      Tezos.Crypto.Util       Util.Alternative       Util.Default       Util.Generic       Util.Instances       Util.IO       Util.Lens+      Util.Markdown       Util.Named       Util.Peano+      Util.Positive       Util.Test.Arbitrary       Util.Test.Ingredients+      Util.Text       Util.Type+      Util.Typeable+      Util.TypeLits       Util.TypeTuple       Util.TypeTuple.Class       Util.TypeTuple.Instances@@ -140,7 +185,7 @@   hs-source-dirs:       src   default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0   build-depends:       QuickCheck     , aeson@@ -149,18 +194,21 @@     , base-noprelude >=4.7 && <5     , base16-bytestring     , base58-bytestring+    , bimap     , binary     , bytestring-    , constraints+    , constraints >=0.11     , containers     , cryptonite     , data-default-    , filepath+    , first-class-families >=0.5.0.0     , fmt     , formatting     , ghc-prim+    , gitrev     , hex-text     , hspec+    , interpolate     , lens     , megaparsec >=7.0.0     , memory@@ -168,42 +216,26 @@     , mtl     , named     , parser-combinators >=1.0.0+    , pretty-terminal     , quickcheck-arbitrary-adt     , quickcheck-instances+    , show-type     , singletons     , syb     , tasty     , tasty-ant-xml+    , tasty-hunit     , template-haskell     , text     , time     , timerep     , transformers-compat ==0.6.5+    , unordered-containers     , vector     , vinyl     , wl-pprint-text   default-language: Haskell2010 -executable contract-discover-  main-is: Main.hs-  other-modules:-      Paths_morley-  hs-source-dirs:-      contract-discover-  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude-  build-depends:-      base-noprelude >=4.7 && <5-    , data-default-    , directory-    , filepath-    , fmt-    , megaparsec-    , morley-    , morley-prelude-    , text-  default-language: Haskell2010- executable morley   main-is: Main.hs   other-modules:@@ -213,7 +245,7 @@   hs-source-dirs:       app   default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0   build-depends:       base-noprelude >=4.7 && <5     , fmt@@ -228,31 +260,58 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      Test.Analyzer       Test.CValConversion+      Test.Doc+      Test.EntryPoints       Test.Ext+      Test.Integrational       Test.Interpreter-      Test.Interpreter.A1.Feather+      Test.Interpreter.Auction       Test.Interpreter.CallSelf       Test.Interpreter.Compare       Test.Interpreter.Conditionals       Test.Interpreter.ContractOp       Test.Interpreter.EnvironmentSpec       Test.Interpreter.StringCaller-      Test.Lorentz.Discovery+      Test.Lorentz.Base+      Test.Lorentz.DeadCode+      Test.Lorentz.EntryPoints+      Test.Lorentz.Errors+      Test.Lorentz.Extensible       Test.Lorentz.Macro+      Test.Lorentz.Print+      Test.Lorentz.UParam+      Test.Lorentz.UStore.Behaviour+      Test.Lorentz.UStore.Migration.Batched+      Test.Lorentz.UStore.Migration.Batched.V1+      Test.Lorentz.UStore.Migration.Batched.V2+      Test.Lorentz.UStore.Migration.FillInParts+      Test.Lorentz.UStore.Migration.Simple+      Test.Lorentz.UStore.Migration.Simple.V1+      Test.Lorentz.UStore.Migration.Simple.V2+      Test.Lorentz.UStore.SafeLift+      Test.Lorentz.UStore.SafeLift.Helpers       Test.Macro       Test.Michelson.Runtime       Test.Michelson.Text+      Test.Michelson.Typed.Util+      Test.OpSize+      Test.Optimizer       Test.Parser+      Test.Preprocess       Test.Printer.Michelson       Test.Serialization.Aeson       Test.Serialization.Michelson       Test.Tasty.HUnit       Test.Tezos.Address+      Test.Tezos.Core       Test.Tezos.Crypto+      Test.Tezos.Crypto.Hash       Test.Typecheck       Test.Untyped.Instr       Test.Util.Contracts+      Test.Util.HUnit       Test.Util.Parser       Test.Util.QuickCheck       Test.ValConversion@@ -261,7 +320,7 @@   hs-source-dirs:       test   default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -with-rtsopts=-N+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0 -threaded -with-rtsopts=-N   build-tool-depends:       tasty-discover:tasty-discover   build-depends:@@ -269,14 +328,15 @@     , QuickCheck     , aeson     , base-noprelude >=4.7 && <5+    , bimap     , bytestring+    , constraints     , containers     , data-default     , directory     , filepath     , fmt     , formatting-    , generic-arbitrary     , hex-text     , hspec     , hspec-expectations@@ -284,14 +344,15 @@     , megaparsec >=7.0.0     , morley     , morley-prelude-    , mtl-    , qm-interpolated-string     , quickcheck-arbitrary-adt     , quickcheck-instances     , singletons+    , spoon     , syb     , tasty     , tasty-hspec     , tasty-quickcheck     , text+    , unordered-containers+    , vinyl   default-language: Haskell2010

@@ -6,14 +6,26 @@ import Lorentz.Arith as Exports import Lorentz.Base as Exports import Lorentz.Coercions as Exports+import Lorentz.Common as Exports import Lorentz.Constraints as Exports+import Lorentz.Doc as Exports+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.Ext as Exports import Lorentz.Instr as Exports import Lorentz.Macro as Exports+import Lorentz.Pack as Exports import Lorentz.Polymorphic as Exports import Lorentz.Prelude as Exports+import Lorentz.Print as Exports import Lorentz.Rebinded as Exports import Lorentz.Referenced as Exports-import Lorentz.Store as Exports+import Lorentz.Run as Exports+import Lorentz.StoreClass as Exports+import Lorentz.UParam as Exports+import Lorentz.UStore as Exports import Lorentz.Value as Exports+import Lorentz.Zip as Exports ()

@@ -1,3 +1,5 @@+{-# LANGUAGE FunctionalDependencies #-}+ module Lorentz.ADT   ( HasField   , HasFieldOfType@@ -16,7 +18,10 @@   , wrap_   , case_   , caseT-  , (/->)+  , unwrapUnsafe_+  , CaseTC+  , CaseArrow (..)+  , CaseClauseL (..)   , InstrConstructC   , ConstructorFieldTypes @@ -25,6 +30,8 @@   , (:!)   , (:?)   , arg+  , argDef+  , argF   ) where  import Data.Constraint (Dict(..))@@ -32,7 +39,7 @@ import Data.Vinyl.Core (RMap(..), Rec(..)) import Data.Vinyl.Derived (Label) import GHC.TypeLits (AppendSymbol, Symbol)-import Named ((:!), (:?), arg)+import Named ((:!), (:?), arg, argDef, argF)  import Lorentz.Base import Lorentz.Coercions@@ -56,6 +63,7 @@ -- | A pair of field name and type. data NamedField = NamedField Symbol Kind.Type type n := ty = 'NamedField n ty+infixr 0 :=  -- | Shortcut for multiple 'HasFieldOfType' constraints. type family HasFieldsOfType (dt :: Kind.Type) (fs :: [NamedField])@@ -146,8 +154,10 @@ constructT = construct . recFromTuple  -- | Lift an instruction to field constructor.-fieldCtor :: (st :-> f & st) -> FieldConstructor st f-fieldCtor (I i) = FieldConstructor i+fieldCtor :: HasCallStack => (st :-> f & st) -> FieldConstructor st f+fieldCtor = \case+  I i -> FieldConstructor i+  FI _ -> error "Field constructor always fails"  -- | Wrap entry in constructor. Useful for sum types. wrap_@@ -162,21 +172,25 @@ data CaseClauseL (inp :: [Kind.Type]) (out :: [Kind.Type]) (param :: CaseClauseParam) where   CaseClauseL :: AppendCtorField x inp :-> out -> CaseClauseL inp out ('CaseClauseParam ctor x) --- | Lift an instruction to case clause.------ You should write out constructor name corresponding to the clause--- explicitly. Prefix constructor name with "c" letter, otherwise--- your label will not be recognized by Haskell parser.--- Passing constructor name can be circumvented but doing so is not recomended--- as mentioning contructor name improves readability and allows avoiding--- some mistakes.-(/->)-  :: Label ("c" `AppendSymbol` ctor)-  -> AppendCtorField x inp :-> out-  -> CaseClauseL inp out ('CaseClauseParam ctor x)-(/->) _ = CaseClauseL-infixr 0 /->+-- | Provides "case" arrow which works on different wrappers for clauses.+class CaseArrow name body clause | clause -> name, clause -> body where+  -- | Lift an instruction to case clause.+  --+  -- You should write out constructor name corresponding to the clause+  -- explicitly. Prefix constructor name with "c" letter, otherwise+  -- your label will not be recognized by Haskell parser.+  -- Passing constructor name can be circumvented but doing so is not recomended+  -- as mentioning contructor name improves readability and allows avoiding+  -- some mistakes.+  (/->) :: Label name -> body -> clause+  infixr 0 /-> +instance ( name ~ ("c" `AppendSymbol` ctor)+         , body ~ (AppendCtorField x inp :-> out)+         ) => CaseArrow name body+                (CaseClauseL inp out ('CaseClauseParam ctor x)) where+  (/->) _ = CaseClauseL+ -- | Pattern match on the given sum type. -- -- You have to provide a 'Rec' containing case branches.@@ -187,23 +201,40 @@      , RMap (CaseClauses dt)      )   => Rec (CaseClauseL inp out) (CaseClauses dt) -> dt & inp :-> out-case_ = I . instrCase @dt . rmap coerceCaseClause+case_ = LorentzInstr . instrCase @dt . rmap coerceCaseClause   where     coerceCaseClause       :: forall clauses.          CaseClauseL inp out clauses -> CaseClause (ToTs inp) (ToTs out) clauses-    coerceCaseClause (CaseClauseL (I cc)) =+    coerceCaseClause (CaseClauseL (LorentzInstr cc)) =       CaseClause $ case Proxy @clauses of         (_ :: Proxy ('CaseClauseParam ctor cc)) ->           case appendCtorFieldAxiom @cc @inp of Dict -> cc  -- | Like 'case_', accepts a tuple of clauses, which may be more convenient.+--+-- If user is experiencing problems with wierd errors about tuples while using+-- this function, he should take look at `Util.TypeTuple.Instances` and ensure+-- that his tuple isn't bigger than generated instances, if so, he should probably+-- extend number of generated instances. caseT   :: forall dt out inp clauses.-     ( InstrCaseC dt inp out-     , RMap (CaseClauses dt)-     , RecFromTuple clauses-     , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt)-     )+     CaseTC dt out inp clauses   => IsoRecTuple clauses -> dt & inp :-> out caseT = case_ @dt . recFromTuple++type CaseTC dt out inp clauses =+  ( InstrCaseC dt inp out+  , RMap (CaseClauses dt)+  , RecFromTuple clauses+  , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt)+  )++-- | Wrap entry in constructor. Useful for sum types.+unwrapUnsafe_+  :: forall dt name st.+     InstrUnwrapC dt name+  => Label name -> dt & st :-> (CtorOnlyField name dt ': st)+unwrapUnsafe_ =+  case appendCtorFieldAxiom @(GetCtorField dt name) @st of+    Dict -> I . instrUnwrapUnsafe @dt

@@ -1,6 +1,7 @@ -- | Type families from 'Michelson.Typed.Arith' lifted to Haskell types. module Lorentz.Arith   ( ArithOpHs (..)+  , CompareOpHs   , UnaryArithOpHs (..)   ) where @@ -108,24 +109,20 @@ instance UnaryArithOpHs Not Bool where   type UnaryArithResHs Not Bool = Bool -instance ArithOpHs Compare Bool Bool where-  type ArithResHs Compare Bool Bool = Integer-instance ArithOpHs Compare Address Address where-  type ArithResHs Compare Address Address = Integer-instance ArithOpHs Compare Natural Natural where-  type ArithResHs Compare Natural Natural = Integer-instance ArithOpHs Compare Integer Integer where-  type ArithResHs Compare Integer Integer = Integer-instance ArithOpHs Compare MText MText where-  type ArithResHs Compare MText MText = Integer-instance ArithOpHs Compare ByteString ByteString where-  type ArithResHs Compare ByteString ByteString = Integer-instance ArithOpHs Compare Timestamp Timestamp where-  type ArithResHs Compare Timestamp Timestamp = Integer-instance ArithOpHs Compare Mutez Mutez where-  type ArithResHs Compare Mutez Mutez = Integer-instance ArithOpHs Compare KeyHash KeyHash where-  type ArithResHs Compare KeyHash KeyHash = Integer+class (Typeable (ToCT n), IsComparable n, CompareOp (ToCT n)) =>+      CompareOpHs n+instance (n ~ m, CompareOpHs n) => ArithOpHs Compare n m where+  type ArithResHs Compare n m = Integer+instance CompareOpHs Bool+instance CompareOpHs Address+instance CompareOpHs EpAddress+instance CompareOpHs Natural+instance CompareOpHs Integer+instance CompareOpHs MText+instance CompareOpHs ByteString+instance CompareOpHs Timestamp+instance CompareOpHs Mutez+instance CompareOpHs KeyHash  instance UnaryArithOpHs Eq' Integer where   type UnaryArithResHs Eq' Integer = Bool

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE DerivingStrategies #-}  -- | Foundation of Lorentz development. module Lorentz.Base@@ -6,69 +7,164 @@   , type (%>)   , type (&)   , (#)+  , pattern I+  , pattern FI+  , iGenericIf+  , iAnyCode+  , iNonFailingCode+  , iMapAnyCode -  , compileLorentz-  , compileLorentzContract-  , printLorentzContract+  , parseLorentzValue+  , transformStringsLorentz+  , transformBytesLorentz+  , optimizeLorentz+  , optimizeLorentzWithConf    , ContractOut   , Contract+  , SomeContract (..)   , Lambda-   ) where +import Data.Default (def) import qualified Data.Kind as Kind-import Data.Singletons (SingI)+import Data.Singletons (SingI(..))+import Fmt (Buildable(..))  import Lorentz.Constraints import Lorentz.Value-import Michelson.Printer (printTypedContract)-import Michelson.Typed (Instr(..), T(..), ToT, ToTs, Value'(..))+import Michelson.ErrorPos (InstrCallStack)+import Michelson.Optimizer (OptimizerConf, optimizeWithConf)+import Michelson.Parser (ParserException, parseExpandValue)+import Michelson.Preprocess (transformBytes, transformStrings)+import Michelson.TypeCheck (TCError, runTypeCheckIsolated, typeVerifyValue)+import Michelson.Typed+  (Instr(..), RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr, rfMerge)+import qualified Michelson.Untyped as U  -- | Alias for instruction which hides inner types representation via 'T'.-newtype (inp :: [Kind.Type]) :-> (out :: [Kind.Type]) =-  I { unI :: Instr (ToTs inp) (ToTs out) }-  deriving (Show, Eq)+newtype (inp :: [Kind.Type]) :-> (out :: [Kind.Type]) = LorentzInstr+  { unLorentzInstr :: RemFail Instr (ToTs inp) (ToTs out)+  } deriving (Show, Eq) infixr 1 :-> +instance Semigroup (s :-> s) where+  (<>) = (#)+instance Monoid (s :-> s) where+  mempty = I Nop++pattern I :: Instr (ToTs inp) (ToTs out) -> inp :-> out+pattern I i = LorentzInstr (RfNormal i)++pattern FI :: (forall out'. Instr (ToTs inp) out') -> inp :-> out+pattern FI i = LorentzInstr (RfAlwaysFails i)++{-# COMPLETE I, FI #-}++iGenericIf+  :: (forall s'. Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')+  -> (a :-> s) -> (b :-> s) -> (c :-> s)+iGenericIf merger (LorentzInstr instr1) (LorentzInstr instr2) =+  LorentzInstr (rfMerge merger instr1 instr2)++iAnyCode :: inp :-> out -> Instr (ToTs inp) (ToTs out)+iAnyCode = rfAnyInstr . unLorentzInstr++iNonFailingCode :: HasCallStack => inp :-> out -> Instr (ToTs inp) (ToTs out)+iNonFailingCode (I i) = i+iNonFailingCode (FI _) = error "Always failing code cannot appear here"++iMapAnyCode+  :: (forall o'. Instr (ToTs i1) o' -> Instr (ToTs i2) o')+  -> (i1 :-> o)+  -> (i2 :-> o)+iMapAnyCode f (LorentzInstr i) = LorentzInstr $ rfMapAnyInstr f i++-- There is also @instance IsoValue (i :-> o)@ in a separate module.+ -- | Alias for ':->', seems to make signatures more readable sometimes. -- -- Let's someday decide which one of these two should remain. type (%>) = (:->) infixr 1 %> --- | For use outside of Lorentz.-compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)-compileLorentz = unI- type ContractOut st = '[([Operation], st)] type Contract cp st = '[(cp, st)] :-> ContractOut st --- | Version of 'compileLorentz' specialized to instruction corresponding to--- contract code.-compileLorentzContract-  :: forall cp st.-     (NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st)-  => Contract cp st -> Instr '[ToT (cp, st)] '[ToT ([Operation], st)]-compileLorentzContract = compileLorentz--printLorentzContract-  :: forall cp st.-      ( SingI (ToT cp), SingI (ToT st)-      , NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st-      )-  => Contract cp st -> LText-printLorentzContract = printTypedContract . compileLorentzContract+data SomeContract where+  SomeContract+    :: (NiceParameter cp, NiceStorage st)+    => Contract cp st+    -> SomeContract  type (&) (a :: Kind.Type) (b :: [Kind.Type]) = a ': b infixr 2 &  (#) :: (a :-> b) -> (b :-> c) -> a :-> c I l # I r = I (l `Seq` r)+I l # FI r = FI (l `Seq` r)+FI l # _ = FI l+infixl 8 #  type Lambda i o = '[i] :-> '[o] -instance IsoValue (Lambda inp out) where-  type ToT (Lambda inp out) = 'TLambda (ToT inp) (ToT out)-  toVal = VLam . unI-  fromVal (VLam l) = I l+-- | Errors that can happen during parsing into a Lorentz value.+data ParseLorentzError+  = ParseLorentzParseError !ParserException+  | ParseLorentzTypecheckError !TCError+  deriving stock (Show, Eq)++instance Buildable ParseLorentzError where+  build =+    \case+      ParseLorentzParseError e -> build e+      ParseLorentzTypecheckError e -> build e++-- | Parse textual representation of a Michelson value and turn it+-- into corresponding Haskell value.+--+-- Note: it won't work in some complex cases, e. g. if there is a+-- lambda which uses an instruction which depends on current+-- contract's type. Obviously it can not work, because we don't have+-- any information about a contract to which this value belongs (there+-- is no such contract at all).+parseLorentzValue ::+     forall v. (IsoValue v, SingI (ToT v), Typeable (ToT v))+  => Text+  -> Either ParseLorentzError v+parseLorentzValue =+  fmap fromVal . (toTyped <=< first ParseLorentzParseError . parseExpandValue)+  where+    toTyped :: U.Value -> Either ParseLorentzError (Value (ToT v))+    toTyped =+      first ParseLorentzTypecheckError .+      runTypeCheckIsolated .+      usingReaderT (def @InstrCallStack) .+      typeVerifyValue++-- | Lorentz version of 'transformStrings'.+transformStringsLorentz ::+  Bool -> (MText -> MText) -> inp :-> out -> inp :-> out+transformStringsLorentz goToValues f =+  iMapAnyCode $ transformStrings goToValues f++-- | Lorentz version of 'transformBytes'.+transformBytesLorentz ::+  Bool -> (ByteString -> ByteString) -> inp :-> out -> inp :-> out+transformBytesLorentz goToValues f =+  iMapAnyCode $ transformBytes goToValues f++optimizeLorentzWithConf+  :: OptimizerConf+  -> inp :-> out+  -> inp :-> out+optimizeLorentzWithConf conf =+  -- Optimizer can produce dead code.+  -- Example: @push True # if_ failWith nop # ...@ will fold to @failWith # ...@.+  -- But let's not care about this case for now until need in it fires.+  iMapAnyCode (optimizeWithConf conf)++optimizeLorentz+  :: inp :-> out+  -> inp :-> out+optimizeLorentz = optimizeLorentzWithConf def

@@ -2,12 +2,18 @@ module Lorentz.Coercions   ( Coercible_   , coerce_+  , gcoerce_+  , fakeCoerce    , coerceUnwrap   , coerceWrap   , toNamed   , fromNamed +    -- * Coercions for some basic types+  , futureContract+  , unFutureContract+     -- * Re-exports   , Wrapped (..)   ) where@@ -17,6 +23,8 @@ import Named (NamedF)  import Lorentz.Base+import Lorentz.Instr+import Lorentz.Value import Michelson.Typed  -- | Whether two types have the same Michelson representation.@@ -26,6 +34,13 @@ coerce_ :: Coercible_ a b => a & s :-> b & s coerce_ = I Nop +gcoerce_ :: Coercible_ (t a) (t b) => t a : s :-> t b : s+gcoerce_ = coerce_++-- | Convert between two stacks via failing.+fakeCoerce :: s1 :-> s2+fakeCoerce = unit # I FAILWITH+ -- | Specialized version of 'coerce_' to wrap into a haskell newtype. coerceWrap   :: Coercible_ newtyp (Unwrapped newtyp)@@ -45,3 +60,15 @@ -- | Unpack named value. fromNamed :: Label name -> NamedF Identity a name : s :-> a : s fromNamed _ = coerceUnwrap++----------------------------------------------------------------------------+-- Coercions for some basic types+----------------------------------------------------------------------------++-- | Make up a 'FutureContract'.+futureContract :: Address : s :-> FutureContract p : s+futureContract = coerce_++-- | Get address referred by 'FutureContract'.+unFutureContract :: FutureContract p : s :-> Address : s+unFutureContract = coerce_

@@ -0,0 +1,17 @@+-- | Common primitives.+module Lorentz.Common+  ( Entrypoint+  , Entrypoint_+  ) where++import Lorentz.Base++-- | Single entrypoint of a contract.+--+-- Note that we cannot make it return @[[Operation], store]@ because+-- such entrypoint should've been followed by @pair@, and this is not+-- possible if entrypoint implementation ends with 'failWith'.+type Entrypoint param store = '[ param, store ] :-> ContractOut store++-- | Version of 'Entrypoint' which accepts no argument.+type Entrypoint_ store = '[ store ] :-> ContractOut store

@@ -1,23 +1,98 @@+{-# LANGUAGE UndecidableSuperClasses #-}++-- | Scope-related constraints used in Lorentz. module Lorentz.Constraints-  ( CanHaveBigMap+  ( -- * Grouped constraints+    NiceParameter+  , NiceStorage+  , NiceConstant+  , NicePackedValue+  , NiceUnpackedValue+  , NiceFullPackedValue+  , NicePrintedValue++  , niceParameterEvi+  , niceStorageEvi+  , niceConstantEvi+  , nicePackedValueEvi+  , niceUnpackedValueEvi+  , nicePrintedValueEvi++    -- * Individual constraints (internals)+  , CanHaveBigMap   , KnownValue   , KnownCValue   , NoOperation+  , NoContractType   , NoBigMap++  , -- * Re-exports+    withDict   ) where +import Data.Constraint (trans, weaken2) import Data.Singletons (SingI)  import Michelson.Typed +-- We write these constraints as class + instance, rather than+-- type aliases, in order to allow their partial application.+ -- | Gathers constraints, commonly required for values.-type KnownValue a = (Typeable (ToT a), SingI (ToT a))+class (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a+instance (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a -type KnownCValue a = (IsoValue a, Typeable (ToCT a), SingI (ToCT a))+class (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a+instance (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a  -- | Ensure given type does not contain "operation".-type NoOperation a = ForbidOp (ToT a)+class (IsoValue a, ForbidOp (ToT a)) => NoOperation a+instance (IsoValue a, ForbidOp (ToT a)) => NoOperation a -type NoBigMap a = ForbidBigMap (ToT a)+class (IsoValue a, ForbidContract (ToT a)) => NoContractType a+instance (IsoValue a, ForbidContract (ToT a)) => NoContractType a -type CanHaveBigMap a = AllowBigMap (ToT a)+class (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a+instance (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a++class (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a+instance (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a++-- | Constraint applied to parameter type.+type NiceParameter a = (KnownValue a, ProperParameterBetterErrors (ToT a))++type NiceStorage a = (KnownValue a, ProperStorageBetterErrors (ToT a))++type NiceConstant a = (KnownValue a, ProperConstantBetterErrors (ToT a))++type NicePackedValue a = (KnownValue a, ProperPackedValBetterErrors (ToT a))++type NiceUnpackedValue a = (KnownValue a, ProperUnpackedValBetterErrors (ToT a))++type NiceFullPackedValue a = (NicePackedValue a, NiceUnpackedValue a)++type NicePrintedValue a = (KnownValue a, ProperPrintedValBetterErrors (ToT a))++niceParameterEvi :: forall a. NiceParameter a :- ParameterScope (ToT a)+niceParameterEvi =+  properParameterEvi @(ToT a) `trans` weaken2++niceStorageEvi :: forall a. NiceStorage a :- StorageScope (ToT a)+niceStorageEvi =+  properStorageEvi @(ToT a) `trans` weaken2++niceConstantEvi :: forall a. NiceConstant a :- ConstantScope (ToT a)+niceConstantEvi =+  properConstantEvi @(ToT a) `trans` weaken2++nicePackedValueEvi :: forall a. NicePackedValue a :- PackedValScope (ToT a)+nicePackedValueEvi =+  properPackedValEvi @(ToT a) `trans` weaken2++niceUnpackedValueEvi :: forall a. NiceUnpackedValue a :- UnpackedValScope (ToT a)+niceUnpackedValueEvi =+  properUnpackedValEvi @(ToT a) `trans` weaken2++nicePrintedValueEvi :: forall a. NicePrintedValue a :- PrintedValScope (ToT a)+nicePrintedValueEvi =+  properPrintedValEvi @(ToT a) `trans` weaken2

@@ -1,118 +0,0 @@--- | Utilities used for contracts discovery.------ All the discovery logic resides in 'lorentz-discover' executable.-module Lorentz.Discover-  ( IsContract (..)--  , ExportedContractInfo (..)-  , ExportedContractDecl (..)--  , isHaskellModule-  , haskellExportsParser-  ) where--import Data.Char (isAlphaNum)-import Data.Singletons (SingI)-import qualified Data.Text as T-import System.FilePath.Posix (takeExtension, takeFileName)-import Text.Megaparsec (Parsec)-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Char as P-import qualified Text.Megaparsec.Char.Lexer as PL--import qualified Lorentz.Base as L-import Lorentz.Constraints-import qualified Michelson.Typed as T-import qualified Michelson.Untyped as U---- | Defined for values representing a contract.-class IsContract c where-  toUntypedContract :: c -> U.Contract--instance IsContract U.Contract where-  toUntypedContract = id--instance (SingI cp, SingI st) => IsContract (T.Contract cp st) where-  toUntypedContract = T.convertContract--instance ( SingI (T.ToT cp), SingI (T.ToT st)-         , NoOperation cp, NoOperation st, NoBigMap cp, CanHaveBigMap st-         ) =>-         IsContract (L.Contract cp st) where-  toUntypedContract = toUntypedContract . L.compileLorentzContract---- | Information about a contract required for contracts registry.-data ExportedContractInfo = ExportedContractInfo-  { eciModuleName :: Text-  , eciContractDecl :: ExportedContractDecl-  } deriving (Show, Eq)---- | Contract names, for Haskell and for humans.-data ExportedContractDecl = ExportedContractDecl-  { ecdName :: Text-    -- ^ Identifier of a contract, e.g. "auction".-  , ecdVar :: Text-    -- ^ Name of a contract as is appears in Haskell code.-  } deriving (Show, Eq)--isHaskellModule :: FilePath -> Bool-isHaskellModule path =-  let file = takeFileName path-  in and-     [ takeExtension file == ".hs"-     , all (\c -> isAlphaNum c || c == '_' || c == '.') file-     ]--haskellExportsParser :: Parsec Void Text [ExportedContractInfo]-haskellExportsParser = do-  space-  symbol "module"-  moduleName <--    lexeme $ P.takeWhile1P (Just "module name")-                           (\c -> isAlphaNum c || c `elem` ['.', '_'])-  symbol "("-  exports <- exportItems-  symbol ")"-  symbol "where"-  return-    [ ExportedContractInfo-      { eciModuleName = moduleName-      , eciContractDecl = decl-      }-    | exportRaw <- exports-    , let export = T.strip exportRaw-    , Just decl <- pure $ toContractDecl export-    ]-  where-    exportItems :: Parsec Void Text [Text]-    exportItems = P.sepBy exportItem (symbol ",")--    -- We do not follow the syntax precisely, just trying to parse-    -- all valid Haskell programs-    exportItem = fmap mconcat . many . lexeme $-      P.choice-        [ P.takeWhile1P Nothing isExportEntryChar-        , do symbol "("-             _ <- exportItems-             symbol ")"-             return "(..)"  -- we are not interested in content-        , symbol ".." $> ".."-        ]--    space = PL.space P.space1 (PL.skipLineComment "--")-                              (PL.skipBlockComment "{-" "-}")-    lexeme = PL.lexeme space-    symbol = void . PL.symbol space--isExportEntryChar :: Char -> Bool-isExportEntryChar c = isAlphaNum c || c == '_'--toContractDecl :: Text -> Maybe ExportedContractDecl-toContractDecl varName = do-  rawName <- T.stripPrefix "contract_" varName-  guard $ all isExportEntryChar $ toString rawName-  let name = T.replace "_" " " rawName-  return ExportedContractDecl-    { ecdName = name-    , ecdVar = varName-    }

@@ -0,0 +1,133 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.Doc+  ( doc+  , docGroup+  , buildLorentzDoc+  , renderLorentzDoc+  , contractName+  , cutLorentzNonDoc++    -- * Re-exports+  , Markdown+  , DocItem (..)+  , docItemPosition+  , DocItemId (..)+  , DocItemPlacementKind (..)+  , DocItemRef (..)+  , DocSectionNameStyle (..)+  , SomeDocItem (..)+  , SomeDocDefinitionItem (..)+  , SubDoc (..)+  , DocGrouping+  , ContractDoc (..)+  , DDescription (..)+  , DVersion (..)+  , DGitRevision (..)+  , GitRepoSettings (..)+  , mkDGitRevision+  , morleyRepoSettings+  , DComment (..)+  , DType (..)+  , docDefinitionRef+  , contractDocToMarkdown+  , subDocToMarkdown++  , TypeHasDoc (..)+  , SomeTypeWithDoc (..)++  , HaveCommonTypeCtor+  , IsHomomorphic+  , genericTypeDocDependencies+  , customTypeDocMdReference+  , homomorphicTypeDocMdReference+  , poly1TypeDocMdReference+  , poly2TypeDocMdReference+  , homomorphicTypeDocHaskellRep+  , concreteTypeDocHaskellRep+  , concreteTypeDocHaskellRepUnsafe+  , haskellRepNoFields+  , haskellRepStripFieldPrefix+  , homomorphicTypeDocMichelsonRep+  , concreteTypeDocMichelsonRep+  , concreteTypeDocMichelsonRepUnsafe+  ) where++import Data.Singletons (demote)++import Lorentz.Base+import Lorentz.Value+import Lorentz.Zip ()+import Michelson.Doc+import Michelson.Optimizer+import Michelson.Typed+import Util.Markdown+import Util.Type++-- | Put a document item.+doc :: DocItem di => di -> s :-> s+doc = I . Ext . DOC_ITEM . SomeDocItem++-- | Group documentation built in the given piece of code+-- into block dedicated to one thing, e.g. to one entry point.+docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out)+docGroup gr = iMapAnyCode (DocGroup gr)++-- | Give a name to given contract. Apply it to the whole contract code.+contractName :: Text -> (inp :-> out) -> (inp :-> out)+contractName name = docGroup (SomeDocItem . DName name)++buildLorentzDoc :: inp :-> out -> ContractDoc+buildLorentzDoc (iAnyCode -> code) = buildInstrDoc code++renderLorentzDoc :: inp :-> out -> LText+renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc++-- | Leave only instructions related to documentation.+--+-- This function is useful when your method executes a lambda coming from outside,+-- but you know its properties and want to propagate its documentation to your+-- contract code.+cutLorentzNonDoc :: (inp :-> out) -> (s :-> s)+cutLorentzNonDoc (iAnyCode -> code) = I $ cutInstrNonDoc optimize code++instance Each [Typeable, ReifyList TypeHasDoc] [i, o] =>+         TypeHasDoc (i :-> o) where+  typeDocName _ = "Code (extended lambda)"+  typeDocMdReference tp wp =+    let DocItemRef (DocItemId ctorDocItemId) = docItemRef (DType tp)+        refToThis = mdLocalRef (mdTicked "Code") ctorDocItemId+    in applyWithinParens wp $+      mconcat $ intersperse " " [refToThis, refToStack @i, refToStack @o]+    where+    refToStack :: forall s. ReifyList TypeHasDoc s => Markdown+    refToStack =+      let stack = reifyList @_ @TypeHasDoc @s (\p -> typeDocMdReference p (WithinParens False))+      in mconcat+          [ mdBold "["+          , case stack of+              [] -> " "+              st -> mconcat $ intersperse (mdBold "," <> " ") st+          , mdBold "]"+          ]++  typeDocMdDescription =+    "`Code i o` stands for a sequence of instructions which accepts stack \+    \of type `i` and returns stack of type `o`.\n\n\+    \When both `i` and `o` are of length 1, this primitive corresponds to \+    \the Michelson lambda. In more complex cases code is surrounded with `pair`\+    \and `unpair` instructions until fits into mentioned restriction.\+    \"+  typeDocDependencies _ = mconcat+    [ reifyList @_ @TypeHasDoc @i SomeTypeWithDoc+    , reifyList @_ @TypeHasDoc @o SomeTypeWithDoc+    , [ SomeTypeWithDoc (Proxy @Integer)+      , SomeTypeWithDoc (Proxy @Natural)+      , SomeTypeWithDoc (Proxy @MText)+      ]+    ]+  typeDocHaskellRep _ = Nothing+  typeDocMichelsonRep _ =+    ( Just "Code [Integer, Natural, MText, ()] [ByteString]"+    , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))+    )

@@ -0,0 +1,349 @@+{-# LANGUAGE UndecidableSuperClasses #-}++module Lorentz.EntryPoints+  ( ParameterEntryPoints (..)+  , ParameterEntryPointsSplit (..)+  , mapParameterEntryPoints+  , pepNone+  , pepPlain+  , pepRecursive+  ) where++import qualified Data.Kind as Kind+import Data.Singletons (SingI)+import Data.Type.Bool (If)+import qualified GHC.Generics as G+import Named (NamedF)++import Lorentz.Base ((:->))+import Lorentz.Constraints+import Lorentz.Zip+import Michelson.Text+import Michelson.Typed+  (BigMap, ContractRef(..), EpAddress, Notes(..), Operation, T(..), ToT, ToCT,+  starNotes)+import Michelson.Typed.Haskell.Instr.Sum (IsPrimitiveValue)+import Michelson.Typed.Haskell.Value (GValueType, IsGenericIsoValue)+import Michelson.Untyped (Annotation(..), FieldAnn, TypeAnn, ann, noAnn)+import Tezos.Address+import Tezos.Core+import Tezos.Crypto+import Util.Text+import Util.TypeLits++-- | Which entrypoints given parameter declares.+class NiceParameter p => ParameterEntryPoints p where+  parameterEntryPoints :: ParameterEntryPointsSplit p++-- | Implementation of 'parameterEntryPoints'.+newtype ParameterEntryPointsSplit p = ParameterEntryPointsSplit+  { pesNotes :: Notes (ToT p)+    -- ^ Parameter annotations which declare necessary entrypoints.+  }++mapParameterEntryPoints+  :: (ToT a ~ ToT b)+  => (a -> b) -> ParameterEntryPointsSplit a -> ParameterEntryPointsSplit b+mapParameterEntryPoints _ ParameterEntryPointsSplit{..} =+  ParameterEntryPointsSplit{..}++-- | No entrypoints declared, parameter type will serve as argument type+-- of the only existing entrypoint.+pepNone :: SingI (ToT p) => ParameterEntryPointsSplit p+pepNone = ParameterEntryPointsSplit starNotes++instance ParameterEntryPoints () where+  parameterEntryPoints = pepNone++-- Common implementations+----------------------------------------------------------------------------++-- | Fits for case when your contract exposes multiple entrypoints+-- via having sum type as its parameter.+--+-- In particular, this will attach field annotations to immediate parameter "arms"+-- which will be named as corresponding constructor names.+pepPlain :: PesEntryPointsC 'False cp st => ParameterEntryPointsSplit cp+pepPlain = pepEntryPointsExt @'False++-- | Similar to 'pesEntryPoints', but for case of parameter being defined as+-- several nested datatypes.+--+-- In particular, this will traverse sum types recursively, stopping at+-- Michelson primitives (like 'Natural') and constructors with number of+-- fields different from one.+pepRecursive :: PesEntryPointsC 'True cp st => ParameterEntryPointsSplit cp+pepRecursive = pepEntryPointsExt @'True++pepEntryPointsExt+  :: forall deep cp st.+     (PesEntryPointsC deep cp st)+  => ParameterEntryPointsSplit cp+pepEntryPointsExt = ParameterEntryPointsSplit $+  mkEntryPointsNotes @deep @(BuildEPTree deep cp) @cp++type PesEntryPointsC deep cp st =+  ( IsGenericIsoValue cp+  , EntryPointsNotes deep (BuildEPTree deep cp) cp+  , GRequireSumType (G.Rep cp)+  , HasCallStack+  )++-- | Turn constructor name into an appropriate field annotation.+ctorNameToAnn :: HasCallStack => Text -> FieldAnn+ctorNameToAnn = Annotation . headToLower++-- | Ensure that given type is a sum type.+--+-- This helps to prevent attempts to apply a function to, for instance, a pair.+type family GRequireSumType (x :: Kind.Type -> Kind.Type) :: Constraint where+  GRequireSumType (G.M1 _ _ x) = GRequireSumType x+  GRequireSumType (_ G.:+: _) = ()+  GRequireSumType _ = TypeError ('Text "Expected sum type")++-- | Entrypoints tree - skeleton on 'TOr' tree later used to distinguish+-- between constructors-entrypoints and constructors which consolidate+-- a whole pack of entrypoints.+data EPTree+  = EPNode EPTree EPTree+  | EPLeaf++-- | Build 'EPTree' by parameter type.+type BuildEPTree deep a = GBuildEntryPointsTree deep (G.Rep a)++type family GBuildEntryPointsTree (deep :: Bool) (x :: Kind.Type -> Kind.Type)+             :: EPTree where+  GBuildEntryPointsTree deep (G.D1 _ x) =+    GBuildEntryPointsTree deep x+  GBuildEntryPointsTree deep (x G.:+: y) =+    'EPNode (GBuildEntryPointsTree deep x) (GBuildEntryPointsTree deep y)+  GBuildEntryPointsTree 'False (G.C1 _ _) =+    'EPLeaf+  GBuildEntryPointsTree 'True (G.C1 _ x) =+    GBuildEntryPointsTree 'True x+  GBuildEntryPointsTree deep (G.S1 _ x) =+    GBuildEntryPointsTree deep x+  GBuildEntryPointsTree _ G.U1 =+    'EPLeaf+  GBuildEntryPointsTree _ (_ G.:*: _) =+    'EPLeaf+  GBuildEntryPointsTree deep (G.Rec0 a) =+    If (IsPrimitiveValue a)+       'EPLeaf+       (BuildEPTree deep a)++-- | Traverses sum type and constructs 'Notes' which report+-- constructor names via field annotations.+type EntryPointsNotes deep ep a = (Generic a, GEntryPointsNotes deep ep (G.Rep a))++-- | Makes up notes with proper field annotations for given parameter.+mkEntryPointsNotes+  :: forall deep ep a.+      (EntryPointsNotes deep ep a, IsGenericIsoValue a, HasCallStack)+  => Notes (ToT a)+mkEntryPointsNotes = fst $ gMkEntryPointsNotes @deep @ep @(G.Rep a)++-- | Generic traversal for 'EntryPointsNotes'.+class GEntryPointsNotes (deep :: Bool) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where+  {- | Returns:+    1. Notes corresponding to this level;+    2. Field annotation for this level (and which should be used one level above).+  -}+  gMkEntryPointsNotes :: HasCallStack => (Notes (GValueType x), FieldAnn)++instance GEntryPointsNotes deep ep x => GEntryPointsNotes deep ep (G.D1 i x) where+  gMkEntryPointsNotes = gMkEntryPointsNotes @deep @ep @x++instance+    ( GEntryPointsNotes deep epx x+    , GEntryPointsNotes deep epy y+    )+  =>+    GEntryPointsNotes deep ('EPNode epx epy) (x G.:+: y)+  where+  gMkEntryPointsNotes =+    let (xnotes, xann) = gMkEntryPointsNotes @deep @epx @x+        (ynotes, yann) = gMkEntryPointsNotes @deep @epy @y+    in (NTOr noAnn xann yann xnotes ynotes, noAnn)++instance (GHasTypeAnn x, KnownSymbol ctor) =>+         GEntryPointsNotes 'False ep (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gMkEntryPointsNotes =+    (gGetTypeAnn @x, ctorNameToAnn (symbolValT' @ctor))++instance (GHasTypeAnn x, KnownSymbol ctor) =>+         GEntryPointsNotes 'True 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gMkEntryPointsNotes =+    (gGetTypeAnn @x, ctorNameToAnn (symbolValT' @ctor))++instance (ep ~ 'EPNode epx epy, GEntryPointsNotes 'True ep x) =>+         GEntryPointsNotes 'True ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gMkEntryPointsNotes = gMkEntryPointsNotes @'True @ep @x++instance GEntryPointsNotes deep ep x => GEntryPointsNotes deep ep (G.S1 i x) where+  gMkEntryPointsNotes = gMkEntryPointsNotes @deep @ep @x++instance (EntryPointsNotes deep ep a, IsGenericIsoValue a) =>+         GEntryPointsNotes deep ep (G.Rec0 a) where+  gMkEntryPointsNotes = (mkEntryPointsNotes @deep @ep @a, noAnn)++instance GEntryPointsNotes deep 'EPLeaf G.U1 where+  gMkEntryPointsNotes = (starNotes, noAnn)++instance+    ( Typeable (GValueType x)+    , Typeable (GValueType y)+    , SingI (GValueType x)+    , SingI (GValueType y)+    )+  =>+    GEntryPointsNotes deep 'EPLeaf (x G.:*: y)+  where+  gMkEntryPointsNotes = (starNotes, noAnn)++-- For supporting type annotations of entrypoint arguments.+--+--At the botton of this infra is the HasTypeAnn class, which defines the type+--annotations for a given type. Right now the type annotations can only come+--from names in a named field. That is, we are not deriving names from, for+--example, record field names.++class HasTypeAnn a where+  getTypeAnn :: Notes (ToT a)++instance {-# OVERLAPPABLE #-} (GHasTypeAnn (G.Rep a), GValueType (G.Rep a) ~ ToT a)+  => HasTypeAnn a where+  getTypeAnn = gGetTypeAnn @(G.Rep a)++instance (HasTypeAnn a, KnownSymbol name)+  => HasTypeAnn (NamedF Identity a name) where+  getTypeAnn = insertNote (symbolAnn @name) $ getTypeAnn @a+    where+      symbolAnn :: forall s. KnownSymbol s => TypeAnn+      symbolAnn = ann $ symbolValT' @s+      -- Insert the provided type annotation into the provided note.+      insertNote :: forall (b :: T). TypeAnn -> Notes b -> Notes b+      insertNote nt s = case s of+        NTc _ -> NTc nt+        NTKey _ -> NTKey nt+        NTUnit _ -> NTUnit nt+        NTSignature _ -> NTSignature nt+        NTOption _ n1  -> NTOption nt n1+        NTList _ n1 -> NTList nt n1+        NTSet _ n1 -> NTSet nt n1+        NTOperation _ -> NTOperation nt+        NTContract _ n1 -> NTContract nt n1+        NTPair _ n1 n2 n3 n4 -> NTPair nt n1 n2 n3 n4+        NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4+        NTLambda _ n1 n2 -> NTLambda nt n1 n2+        NTMap _ n1 n2 -> NTMap nt n1 n2+        NTBigMap _ n1 n2 -> NTBigMap nt n1 n2+        NTChainId _ -> NTChainId nt++instance (HasTypeAnn (Maybe a), KnownSymbol name)+  => HasTypeAnn (NamedF Maybe a name) where+  getTypeAnn = getTypeAnn @(NamedF Identity (Maybe a) name)++-- Primitive instances+instance (HasTypeAnn a) => HasTypeAnn (Maybe a) where+  getTypeAnn = NTOption noAnn (getTypeAnn @a)++instance HasTypeAnn Integer where+  getTypeAnn = starNotes++instance HasTypeAnn Natural where+  getTypeAnn = starNotes++instance HasTypeAnn MText where+  getTypeAnn = starNotes++instance HasTypeAnn Bool where+  getTypeAnn = starNotes++instance HasTypeAnn ByteString where+  getTypeAnn = starNotes++instance HasTypeAnn Mutez where+  getTypeAnn = starNotes++instance HasTypeAnn Address where+  getTypeAnn = starNotes++instance HasTypeAnn EpAddress where+  getTypeAnn = starNotes++instance HasTypeAnn KeyHash where+  getTypeAnn = starNotes++instance HasTypeAnn Timestamp where+  getTypeAnn = starNotes++instance HasTypeAnn PublicKey where+  getTypeAnn = starNotes++instance HasTypeAnn Signature where+  getTypeAnn = starNotes++instance (HasTypeAnn a) => HasTypeAnn (ContractRef a) where+  getTypeAnn = NTContract noAnn (getTypeAnn @a)++instance (HasTypeAnn v) => HasTypeAnn (Map k v) where+  getTypeAnn = NTMap noAnn noAnn (getTypeAnn @v)++instance (HasTypeAnn v) => HasTypeAnn (BigMap k v) where+  getTypeAnn = NTBigMap noAnn noAnn (getTypeAnn @v)++instance (SingI (ToCT v), Typeable (ToCT v)) => HasTypeAnn (Set v) where+  getTypeAnn = starNotes++instance (HasTypeAnn a) => HasTypeAnn [a] where+  getTypeAnn = NTList noAnn (getTypeAnn @a)++instance HasTypeAnn Operation where+  getTypeAnn = starNotes++instance+    ( HasTypeAnn (ZippedStack i)+    , HasTypeAnn (ZippedStack o)+    )+  =>+    HasTypeAnn (i :-> o)+  where+  getTypeAnn = NTLambda noAnn+    (getTypeAnn @(ZippedStack i))+    (getTypeAnn @(ZippedStack o))++-- A Generic HasTypeAnn implementation+class GHasTypeAnn a where+  gGetTypeAnn :: Notes (GValueType a)++instance GHasTypeAnn G.U1 where+  gGetTypeAnn = starNotes++instance (GHasTypeAnn x) => GHasTypeAnn (G.M1 i0 i1 x) where+  gGetTypeAnn = gGetTypeAnn @x++instance+    ( GHasTypeAnn x+    , GHasTypeAnn y+    )+  =>+    GHasTypeAnn (x G.:+: y)+  where+  gGetTypeAnn = NTOr noAnn noAnn noAnn+    (gGetTypeAnn @x)+    (gGetTypeAnn @y)++instance+    ( GHasTypeAnn x+    , GHasTypeAnn y+    )+  =>+    GHasTypeAnn (x G.:*: y)+  where+  gGetTypeAnn = NTPair noAnn noAnn noAnn+    (gGetTypeAnn @x)+    (gGetTypeAnn @y)++instance (HasTypeAnn x) => GHasTypeAnn (G.Rec0 x) where+  gGetTypeAnn = getTypeAnn @x

@@ -0,0 +1,209 @@+-- | Utilities for declaring and documenting entry points.+module Lorentz.EntryPoints.Doc+  ( DEntryPoint (..)+  , PlainEntryPointsKind+  , diEntryPointToMarkdown+  , DEntryPointArg (..)+  , DeriveCtorFieldDoc (..)+  , ParamBuildingStep (..)+  , clarifyParamBuildingSteps+  , mkDEntryPointArgSimple+  , entryCase+  ) where++import qualified Data.Kind as Kind+import Data.Vinyl.Core (Rec(..), rappend)+import Fmt (build)+import GHC.Generics ((:+:))+import qualified GHC.Generics as G+import GHC.TypeLits (KnownSymbol, symbolVal)++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Doc+import Michelson.Typed.Doc+import Michelson.Typed.Haskell.Doc+import Michelson.Typed.Haskell.Instr+import Util.Markdown+import Util.Type+import Util.TypeTuple++-- | Gathers information about single entry point.+--+-- We assume that entry points might be of different kinds,+-- which is designated by phantom type parameter.+-- For instance, you may want to have several groups of entry points+-- corresponding to various parts of a contract - specifying different @kind@+-- type argument for each of those groups will allow you defining different+-- 'DocItem' instances with appropriate custom descriptions for them.+data DEntryPoint (kind :: Kind.Type) = DEntryPoint Text SubDoc++-- | Default implementation of 'docItemToMarkdown' for entry points.+diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown+diEntryPointToMarkdown lvl (DEntryPoint name block) =+  mdSeparator <>+  mdHeader lvl (mdTicked $ build name) <>+  subDocToMarkdown (nextHeaderLevel lvl) block++-- | Default value for 'DEntryPoint' type argument.+data PlainEntryPointsKind++instance DocItem (DEntryPoint PlainEntryPointsKind) where+  type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000+  docItemSectionName = Just "Entry points"+  docItemToMarkdown = diEntryPointToMarkdown++-- | During incremental assembly of parameter building steps -+-- current representation of parameter.+type CurrentParam = Markdown++-- | Describes a parameter building step.+--+-- This can be wrapping into (Haskell) constructor, or a more complex+-- transformation.+data ParamBuildingStep = ParamBuildingStep+  { pbsEnglish :: Markdown+    -- ^ Plain english description of this step.+  , pbsHaskell :: CurrentParam -> Markdown+    -- ^ How to construct parameter in Haskell code.+  , pbsMichelson :: CurrentParam -> Markdown+    -- ^ How to construct parameter working on raw Michelson.+  }++-- | Describes argument of an entry point.+data DEntryPointArg = DEntryPointArg+  { epaArg :: Maybe DType+    -- ^ Argument of the entry point. Pass 'Nothing' if no argument is required.+  , epaBuilding :: [ParamBuildingStep]+    -- ^ Describes a way to lift an entry point argument into full parameter+    -- which can be passed to the contract.+    --+    -- Steps are supposed to be applied in the order in which they are given.+    -- E.g. suppose that an entry point is called as @Run (Service1 arg)@;+    -- then the first step should describe wrapping into @Service1@ constructor,+    -- and the second step should be about wrapping into @Run@ constructor.+  }++mkDEntryPointArgSimple :: forall t. TypeHasDoc t => DEntryPointArg+mkDEntryPointArgSimple = DEntryPointArg+  { epaArg = Just $ DType (Proxy @t)+  , epaBuilding = []+  }++-- | Go over contract code and update every occurrence of 'DEntryPointArg'+-- documentation item, adding the given step to its "how to build parameter"+-- description.+clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)+clarifyParamBuildingSteps pbs =+  iMapAnyCode $+  modifyInstrDoc (\di -> di{ epaBuilding = epaBuilding di ++ [pbs] })++instance DocItem DEntryPointArg where+  type DocItemPosition DEntryPointArg = 20+  docItemSectionName = Nothing+  docItemDependencies (DEntryPointArg mdty _) =+    [SomeDocDefinitionItem dty | Just dty <- pure mdty]+  docItemToMarkdown _ (DEntryPointArg mdty psteps) =+    mconcat . Prelude.map (<> "\n\n") $+      [ mdSubsection "Parameter" $+          case mdty of+            Nothing -> "none (pass unit)"+            Just (DType dty) -> typeDocMdReference dty (WithinParens False)++      , mdSpoiler "How to call this entry point" . mconcat $+          [ "\n0. Construct parameter for the entry point.\n"+          , mconcat . Prelude.intersperse "\n" $+              psteps <&> \ParamBuildingStep{..} ->+                mconcat . Prelude.intersperse "\n" $+                [ -- Markdown re-enumerates enumerated lists automatically+                  "1. " <> pbsEnglish+                , "    + " <>+                  mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")+                , "    + " <>+                  mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")+                ]+          , "\n\nPass resulting value as parameter to the contract.\n"+          ]+      ]++-- | Pick a type documentation from 'CtorField'.+class DeriveCtorFieldDoc (cf :: CtorField) where+  deriveCtorFieldDoc :: Maybe DType+instance DeriveCtorFieldDoc 'NoFields where+  deriveCtorFieldDoc = Nothing+instance TypeHasDoc ty => DeriveCtorFieldDoc ('OneField ty) where+  deriveCtorFieldDoc = Just $ DType (Proxy @ty)++-- | Add necessary documentation to entry points.+documentEntryPoints+  :: forall a kind inp out.+     DocumentEntryPoints kind a+  => Rec (CaseClauseL inp out) (CaseClauses a)+  -> Rec (CaseClauseL inp out) (CaseClauses a)+documentEntryPoints = gDocumentEntryPoints @kind @(G.Rep a) id++-- | Constraint for 'documentEntryPoints'.+type DocumentEntryPoints kind a =+  (Generic a, GDocumentEntryPoints kind (G.Rep 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 :: Kind.Type) (x :: Kind.Type -> Kind.Type) where+  -- | Add corresponding parameter building step.+  --+  -- First argument is accumulator for Michelson description of the building step.+  gDocumentEntryPoints+    :: (Markdown -> Markdown)+    -> 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 kind x, GDocumentEntryPoints kind y+         , RSplit (GCaseClauses x) (GCaseClauses y)+         ) =>+         GDocumentEntryPoints kind (x :+: y) where+  gDocumentEntryPoints michDesc clauses =+    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses+    in gDocumentEntryPoints @kind @x+         (\a -> michDesc $ "Left (" <> a <> ")")+         lclauses+       `rappend`+       gDocumentEntryPoints @kind @y+         (\a -> michDesc $ "Right (" <> a <> ")")+         rclauses++instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x+         , KnownSymbol ctor+         , DocItem (DEntryPoint kind)+         , DeriveCtorFieldDoc cf+         ) =>+         GDocumentEntryPoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gDocumentEntryPoints michDesc (CaseClauseL clause :& RNil) =+    let entryPointName = toText $ symbolVal (Proxy @ctor)+        psteps = ParamBuildingStep+          { pbsEnglish = "Wrap into " <> mdTicked (build entryPointName) <> " constructor."+          , pbsHaskell = \p -> build entryPointName <> " (" <> p <> ")"+          , pbsMichelson = michDesc+          }+        addDoc instr =+          clarifyParamBuildingSteps psteps $+          docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $+          doc (DEntryPointArg (deriveCtorFieldDoc @cf) []) # instr+    in CaseClauseL (addDoc clause) :& RNil++-- | Like 'caseT', to be used for pattern-matching on parameter.+--+-- Modifies documentation accordingly. Including description of+-- entrypoints' arguments, thus for them you will need to supply+-- 'TypeHasDoc' instance.+entryCase+  :: forall dt entryPointKind out inp clauses.+     ( CaseTC dt out inp clauses+     , DocumentEntryPoints entryPointKind dt+     )+  => Proxy entryPointKind -> IsoRecTuple clauses -> dt & inp :-> out+entryCase _ =+  case_ . documentEntryPoints @dt @entryPointKind . recFromTuple

@@ -1,62 +1,678 @@-{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingStrategies, DeriveAnyClass #-}+{-# LANGUAGE TypeFamilyDependencies #-} --- | Advanced errors.+-- We want to make sure 'failUsingArg' is used with sane argument.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ module Lorentz.Errors-  ( IsError-  , LorentzUserError-  , unLorentzUserError-  , UserFailInstr-  , userFailWith+  ( -- * Haskell to 'Value' conversion+    IsError (..)+  , isoErrorToVal+  , isoErrorFromVal+  , ErrorHasDoc (..)+  , typeDocMdDescriptionReferToError++  , UnspecifiedError (..)++    -- * General instructions+  , failUsing+  , failUnexpected++    -- * Custom errors+  , ErrorArg+  , CustomError (..)+  , failCustom+  , failCustom_++    -- * Documentation+  , ErrorClass (..)+  , CustomErrorHasDoc (..)+  , DError (..)+  , DThrows (..)++    -- * Old interface (DEPRECATED)+  , customErrorToVal+  , customErrorFromVal+  , failUsingArg+  , FailUsingArg+  , CustomErrorNoIsoValue+  , deriveCustomError++  , errorsDocumentation   ) where -import Data.Singletons (SingI)+import Data.Singletons (SingI(..), demote)+import qualified Data.Char as C+import qualified Data.List as L+import Data.Typeable (cast)+import qualified Text.Show+import qualified Language.Haskell.TH as TH import Data.Vinyl.Derived (Label)-import GHC.TypeLits (KnownSymbol, symbolVal)+import Data.Constraint (Dict (..))+import Fmt ((+|), (+||), (|+), (||+), pretty, fmt, build, Buildable)+import qualified Data.Kind as Kind+import Data.Type.Equality (type (==))+import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal, Symbol) -import Lorentz.ADT import Lorentz.Base-import Lorentz.Coercions-import Lorentz.Constraints-import Lorentz.Instr+import Lorentz.Doc+import Lorentz.Instr hiding (cast) import Lorentz.Value import Michelson.Text import Michelson.Typed.Haskell+import Michelson.Typed.Instr+import Michelson.Typed.Scope+import Michelson.Typed.Sing+import Michelson.Typed.T+import Michelson.Typed.Value+import Util.Typeable+import Util.TypeLits+import Util.Type+import Util.Markdown --- | Constraints on an object you can fail with.-type IsError err =-  ( IsoValue err-  , KnownValue err-  , NoOperation err-  , NoBigMap err+----------------------------------------------------------------------------+-- IsError+----------------------------------------------------------------------------++type ErrorScope t =+  -- We can require a weaker constraint (e.g. no 'HasNoOp'), but+  -- for now it's the simplest way to make 'failUsing' work+  ( Typeable t+  , ConstantScope t   ) --- | A unique error identifier.-newtype ErrorTag = ErrorTag MText-  deriving newtype (Show, Eq, Ord, IsString, IsoValue)+type KnownError a = ErrorScope (ToT a) --- | An error indicating a normal failure caused by such user input.-type LorentzUserError e = (ErrorTag, e)+-- | Haskell type representing error.+class (Typeable e, ErrorHasDoc e) => IsError e where --- | Pseudo-getter for error within 'LorentzUserError'.-unLorentzUserError :: LorentzUserError e -> e-unLorentzUserError = snd+  -- | Converts a Haskell error into @Value@ representation.+  errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r +  -- | Converts a @Value@ into Haskell error.+  errorFromVal :: (Typeable t, SingI t) => Value t -> Either Text e++-- | Implementation of 'errorToVal' via 'IsoValue'.+isoErrorToVal+  :: (KnownError e, IsoValue e)+  => e -> (forall t. ErrorScope t => Value t -> r) -> r+isoErrorToVal e cont = cont $ toVal e++-- | Implementation of 'errorFromVal' via 'IsoValue'.+isoErrorFromVal+  :: (Typeable t, Typeable (ToT e), IsoValue e)+  => Value t -> Either Text e+isoErrorFromVal e = fromVal <$> gcastE e++class ErrorHasDoc e where+  -- | Name of error as it appears in the corresponding section title.+  errorDocName :: Text++  -- | What should happen for this error to be raised.+  errorDocMdCause :: Markdown++  -- | Brief version of 'errorDocMdCause'.+  --+  -- This will appear along with the error when mentioned in entrypoint description.+  -- By default, the first sentence of the full description is used.+  errorDocMdCauseInEntrypoint :: Markdown+  errorDocMdCauseInEntrypoint = pickFirstSentence $ errorDocMdCause @e++  -- | How this error is represented in Haskell.+  errorDocHaskellRep :: Markdown++  -- | Error class.+  errorDocClass :: ErrorClass+  errorDocClass = ErrClassUnknown++  -- | Which definitions documentation for this error mentions.+  errorDocDependencies :: [SomeDocDefinitionItem]++-- | Helper for managing descriptions.+pickFirstSentence :: Markdown -> Markdown+pickFirstSentence = build . toText . go . fmt+  where+    go :: String -> String+    go = \case+      '.' : c : _ | C.isSpace c -> "."+      c : s -> c : go s+      "" -> ""++-- Instances+----------------------------------------------------------------------------++-- | Use this for internal errors only.+--+-- "Normal" error scenarios should use the mechanism of custom errors, see below.+instance IsError MText where+  errorToVal = isoErrorToVal+  errorFromVal = isoErrorFromVal++instance ErrorHasDoc MText where+  errorDocName = "InternalError"+  errorDocMdCause =+    "Internal error occured."+  errorDocHaskellRep =+    "Textual error message, see " <>+    typeDocMdReference (Proxy @MText) (WithinParens False) <> "."+  errorDocClass = ErrClassContractInternal+  errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @MText)]++instance TypeError ('Text "Use representative error messages") => IsError () where+  errorToVal _ _ = error "impossible"+  errorFromVal = error "impossible"++instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where+  errorDocName = error "impossible"+  errorDocMdCause = error "impossible"+  errorDocHaskellRep = error "impossible"+  errorDocDependencies = error "impossible"++-- | Use this type as replacement for @()@ when you __really__ want to leave+-- error cause unspecified.+data UnspecifiedError = UnspecifiedError+  deriving stock Generic+  deriving anyclass IsoValue++instance IsError UnspecifiedError where+  errorToVal = isoErrorToVal+  errorFromVal = isoErrorFromVal++instance ErrorHasDoc UnspecifiedError where+  errorDocName = "Unspecified error"+  errorDocMdCause = "Some error occured."+  errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "."+  errorDocDependencies = typeDocDependencies' (Proxy @())++----------------------------------------------------------------------------+-- General instructions+----------------------------------------------------------------------------++-- | Fail with the given Haskell value.+failUsing+  :: forall e s t.+     (IsError e)+  => e -> s :-> t+failUsing err =+  errorToVal err $ \eval ->+    doc (DThrows (Proxy @e)) #+    (FI $ PUSH eval `Seq` FAILWITH)++-- | Fail, providing a reference to the place in the code where+-- this function is called.+--+-- Like 'error' in Haskell code, this instruction is for internal errors only.+failUnexpected :: MText -> s :-> t+failUnexpected msg = failUsing $ [mt|Internal: |] <> msg++----------------------------------------------------------------------------+-- Custom errors+----------------------------------------------------------------------------++{- | Declares a custom error, defining @error name - error argument@ relation.++If your error is supposed to carry no argument, then provide @()@.++Note that this relation is defined globally rather than on per-contract basis,+so define errors accordingly. If your error has argument specific to your+contract, call it such that error name reflects its belonging to this contract.+-}++{- About global registry of errors:++Pros: this allows defining pieces of code which can be reused among the contracts.++Cons: possible name collisions. Example of worst case: two libraries define+different errors for the same tag, attempt to use both of these libraries would+cause compile-time error. But such infrastructure will barely take place in+practice.+-}+{- For future work:++* Assosiating unique numeric error codes to tags, and put codes into+the contract instead of tags. This allows getting rid of overhead related to+often long tag literals.++* Allow using arbitrary type instead of tag (and 'KnownSymbol' constraint will+be replaced with a more generic one).+Some users may prefer using datatypes as tags rather than type-level strings as tags+because+  * there will be no orphan instances then+  * no problem with name collisions+  * compiler will prompt a hint in case of typo in tag name+  * in some cases autocomplete handles declarations in code better than strings+(and cons here is that each such tag will need to be declared first).++-}+type family ErrorArg (tag :: Symbol) :: Kind.Type++-- | Material custom error.+--+-- Use this in pattern matches against error (e.g. in tests).+data CustomError (tag :: Symbol) = CustomError+  { ceTag :: Label tag+  , ceArg :: ErrorArg tag+  }++deriving stock instance Eq (ErrorArg tag) => Eq (CustomError tag)+deriving stock instance Show (ErrorArg tag) => Show (CustomError tag)++-- | How 'CustomError' is actually represented in Michelson.+type CustomErrorRep tag = (MText, ErrorArg tag)++-- | This instance cannot be implemented, use 'IsError' instance instead.+instance TypeError ('Text "CustomError has no IsoValue instance") =>+         IsoValue (CustomError tag) where+  type ToT (CustomError tag) = TypeError ('Text "CustomError has no IsoValue instance")+  toVal = error "impossible"+  fromVal = error "impossible"++instance (CustomErrorHasDoc tag, KnownError (ErrorArg tag), IsoValue (ErrorArg tag)) =>+         IsError (CustomError tag) where+  errorToVal (CustomError l arg) cont =+    cont $ toVal @(CustomErrorRep tag) (errorTagToMText l, arg)+  errorFromVal (v :: Value t) =+    let expectedTag = errorTagToMText (fromLabel @tag)+    in case cast v of+        Just v' ->+          let (tag, arg) = fromVal @(CustomErrorRep tag) v'+          in if tag == expectedTag+             then Right $ CustomError fromLabel arg+             else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ ""+        Nothing -> Left $ "Wrong type for custom error: " <> pretty (demote @t)++instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>+         ErrorHasDoc (CustomError tag) where+  errorDocName = errorTagToText @tag+  errorDocDependencies = typeDocDependencies' (Proxy @(ErrorArg tag))+  errorDocMdCause = customErrDocMdCause @tag+  errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag+  errorDocClass = customErrClass @tag+  errorDocHaskellRep =+    let hasArg = demote @(ToT (ErrorArg tag)) /= TUnit+        name = build $ errorTagToText @tag+    in mconcat $ catMaybes+      [ Just $+          ( if hasArg+            then mdTicked ("(\"" <> name <> "\", " <> "<error argument>" <> ")")+            else mdTicked ("(\"" <> name <> "\", ())")+          ) <> "."+      , guard hasArg $>+          ("\n\nProvided error argument will be of type "+          <> typeDocMdReference (Proxy @(ErrorArg tag)) (WithinParens False)+          <> (maybe "" (\txt -> " and stand for " <> txt) (customErrArgumentSemantics @tag))+          <> "."+          )+      ]++-- | Demote error tag to term level.+errorTagToMText :: KnownSymbol tag => Label tag -> MText+errorTagToMText l =+  -- Now tags come not from constructor names, but from labels,+  -- we have to lead the first letter to upper case to preserve+  -- compatibility with FA1.2 interface.+  mtextHeadToUpper $+    labelToMText l++errorTagToText :: forall tag. KnownSymbol tag => Text+errorTagToText = toText $ errorTagToMText (fromLabel @tag)++-- | Fail with given custom error.+failCustom+  :: forall tag err s any.+     ( err ~ ErrorArg tag+     , CustomErrorHasDoc tag+     , KnownError err+     )+  => Label tag -> err : s :-> any+failCustom l =+  doc (DThrows (Proxy @(CustomError tag))) #+  push (errorTagToMText l) # pair @MText @err #+  FI (FAILWITH @(ToT (CustomErrorRep tag)))++-- | Specialization of 'failCustom' for no-arg errors.+failCustom_+  :: forall tag s any notVoidError.+     ( TypeErrorUnless (ErrorArg tag == ()) notVoidError+     , CustomErrorHasDoc tag+     , notVoidError ~+         ('Text "Expected no-arg error, but given error requires argument of type "+          ':<>: 'ShowType (ErrorArg tag)+         )+     )+  => Label tag -> s :-> any+failCustom_ l =+  inTypeErrorUnless @(ErrorArg tag == ()) @notVoidError $+  reifyTypeEquality @(ErrorArg tag) @() $+    unit # failCustom l++-- Special treatment of no-arg errors+----------------------------------------------------------------------------++instance Eq (ErrorArg tag) => Eq (() -> CustomError tag) where+  e1 == e2 = e1 () == e2 ()+instance Show (ErrorArg tag) => Show (() -> CustomError tag) where+  show e = show (e ())++-- | If 'CustomError' constructor is not provided its argument, we assume+-- that this is no-arg error and interpret the passed value as complete.+instance ( Typeable arg+         , IsError (CustomError tag)+         , TypeErrorUnless (arg == ()) notVoidError+         , arg ~ ErrorArg tag+         , notVoidError ~+            ('Text "This error requires argument of type "+              ':<>: 'ShowType (ErrorArg tag)+            )+         ) =>+         IsError (arg -> CustomError tag) where+  errorToVal mkCustomError cont =+    inTypeErrorUnless @(arg == ()) @notVoidError $+    reifyTypeEquality @arg @() $+      errorToVal (mkCustomError ()) cont+  errorFromVal v =+    inTypeErrorUnless @(arg == ()) @notVoidError $+    reifyTypeEquality @arg @() $+      errorFromVal v <&> \(CustomError l ()) -> CustomError l++instance ErrorHasDoc (CustomError tag) => ErrorHasDoc (arg -> CustomError tag) where+  errorDocName = errorDocName @(CustomError tag)+  errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @(CustomError tag)+  errorDocMdCause = errorDocMdCause @(CustomError tag)+  errorDocHaskellRep = errorDocHaskellRep @(CustomError tag)+  errorDocDependencies = errorDocDependencies @(CustomError tag)++----------------------------------------------------------------------------+-- Errors documentation injection into contracts+----------------------------------------------------------------------------++-- | Error class on how the error should be handled by the client.+data ErrorClass+  = ErrClassActionException+    -- ^ Normal expected error.+    -- Examples: "insufficient balance", "wallet does not exist".+  | ErrClassBadArgument+    -- ^ Invalid argument passed to entrypoint.+    -- Examples: your entrypoint accepts an enum represented as @nat@, and+    -- unknown value is provided.+    -- This includes more complex cases which involve multiple entrypoints.+    -- E.g. API provides iterator interface, middleware should care about using it+    -- hiding complex details and exposing a simpler API to user; then an attempt to+    -- request non-existing element would also correspond to an error from this class.+  | ErrClassContractInternal+    -- ^ Unexpected error. Most likely it means that there is a bug in+    -- the contract or the contract has been deployed incorrectly.+  | ErrClassUnknown+    -- ^ It's possible to leave error class unspecified.++instance Buildable ErrorClass where+  build = \case+    ErrClassActionException -> "Action exception"+    ErrClassBadArgument -> "Bad argument"+    ErrClassContractInternal -> "Internal"+    ErrClassUnknown -> "-"++isInternalErrorClass :: ErrorClass -> Bool+isInternalErrorClass = \case+  ErrClassActionException -> False+  ErrClassBadArgument -> False+  ErrClassContractInternal -> True+  ErrClassUnknown -> False++class (KnownSymbol tag, TypeHasDoc (ErrorArg tag), IsError (CustomError tag)) =>+      CustomErrorHasDoc tag where+  -- | What should happen for this error to be raised.+  customErrDocMdCause :: Markdown++  -- | Brief version of 'customErrDocMdCause'.+  -- This will appear along with the error when mentioned in entrypoint description.+  --+  -- By default, the first sentence of the full description is used.+  customErrDocMdCauseInEntrypoint :: Markdown+  customErrDocMdCauseInEntrypoint = pickFirstSentence $ customErrDocMdCause @tag++  -- | Error class.+  --+  -- By default this returns "unknown error" class; though you should provide+  -- explicit implementation in order to avoid a warning.+  customErrClass :: ErrorClass+  customErrClass = ErrClassUnknown++  -- | Clarification of error argument meaning.+  --+  -- Provide when it's not obvious, e.g. argument is not named with ':!'.+  --+  -- NOTE: This should /not/ be an entire sentence, rather just the semantic+  -- backbone.+  --+  -- Bad:+  -- * @Error argument stands for the previous value of approval.@+  --+  -- Good:+  -- * @the previous value of approval@+  -- * @pair, first argument of which is one thing, and the second is another@+  customErrArgumentSemantics :: Maybe Markdown+  customErrArgumentSemantics = Nothing+  {-# MINIMAL customErrDocMdCause, customErrClass #-}++-- | Mentions that contract uses given error.+data DError where+  DError :: IsError e => Proxy e -> DError++instance Eq DError where+  DError e1 == DError e2 = e1 `eqParam1` e2+instance Ord DError where+  DError e1 `compare` DError e2 = e1 `compareExt` e2++instance DocItem DError where+  type DocItemPosition DError = 5010+  type DocItemPlacement DError = 'DocItemInDefinitions+  docItemSectionName = Just "Errors"+  docItemSectionDescription = Just errorsDocumentation+  docItemRef (DError (_ :: Proxy e)) = DocItemRef $+    DocItemId ("errors-" <> errorDocName @e)+  docItemToMarkdown lvl (DError (_ :: Proxy e)) =+    mconcat+    [ mdSeparator+    , mdHeader lvl (mdTicked . build $ errorDocName @e)+    , mdSubsection "Class" (build $ errorDocClass @e)+    , "\n\n"+    , mdSubsection "Fires if" $ errorDocMdCause @e+    , "\n\n"+    , mdSubsection "Representation" $ errorDocHaskellRep @e+    ]+  docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e++errorDocMdReference :: forall e. IsError e => Markdown+errorDocMdReference =+  let DocItemRef (DocItemId anchor) = docItemRef $ DError (Proxy @e)+  in mdLocalRef (mdTicked . build $ errorDocName @e) anchor++-- | Documentation for custom errors.++-- | Mentions that entrypoint throws given error.+data DThrows where+  DThrows :: IsError e => Proxy e -> DThrows++instance Eq DThrows where+  DThrows e1 == DThrows e2 = eqParam1 e1 e2++instance DocItem DThrows where+  type DocItemPosition DThrows = 5011+  docItemSectionName = Just "Possible errors"+  docItemSectionNameStyle = DocSectionNameSmall+  docItemDependencies (DThrows ds) =+    [SomeDocDefinitionItem (DError ds)]+  docItemToMarkdown _ (DThrows (_ :: Proxy e)) =+    "* " <> errorDocMdReference @e <> " — " <> errorDocMdCauseInEntrypoint @e+  docItemsOrder =+    let errType (DThrows (_ :: Proxy e)) = errorDocClass @e+    in L.nub . filter (Prelude.not . isInternalErrorClass . errType)++-- | Implementation of 'typeDocMdDescription' (of 'TypeHasDoc' typeclass)+-- for Haskell types which sole purpose is to be error.+typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown+typeDocMdDescriptionReferToError =+  "This type is primarily used as error, see " <>+  docDefinitionRef "description in section with errors" (DError (Proxy @e))++-- | This is to be included on top of @Errors@ section of the generated+-- documentation.+errorsDocumentation :: Markdown+errorsDocumentation = [md|+  Our contract implies the possibility of error scenarios, this section enlists+  all values which the contract can produce via calling `FAILWITH` instruction+  on them. In case of error, no changes to contract state will be applied.++  Each entrypoint also contains a list of errors which can be raised during its+  execution; only for no-throw entrypoints this list will be omitted.+  Errors in these lists are placed in the order in which the corresponding+  properties are checked unless the opposite is specified. I.e., if for a+  given entrypoint call two different errors may take place, the one which+  appears in the list first will be thrown.++  Most of the errors are represented according to the same+  `(error name, error argument)` pattern. See the list of errors below+  for details.++  We distinquish several error classes:+  + #{mdBold $ build ErrClassActionException}: given action cannot be performed with+    regard to the current contract state.++    Examples: "insufficient balance", "wallet does not exist".++    If you are implementing a middleware, such errors should be propagated to+    the client.++  + #{mdBold $ build ErrClassBadArgument}: invalid argument supplied to the entrypoint.++    Examples: entrypoint accepts a natural number from `0-3` range, and you+    supply `5`.++    If you are implementing a middleware, you should care about not letting+    such errors happen.++  + #{mdBold $ build ErrClassContractInternal}: contract-internal error.++    In ideal case, such errors should not take place, but still, make sure+    that you are ready to handle them. They can signal either invalid contract+    deployment or a bug in contract implementation.++    If an internal error is thrown, please report it to the author of this contract.+  |]++----------------------------------------------------------------------------+-- Old interface (DEPRECATED)+----------------------------------------------------------------------------++{- This API implements an approach when errors are declared via datatype+with constructors corresponding to error scenarios.+-}++-- | Implementation of 'errorToVal' for custom errors.+customErrorToVal+  :: (LooseSumC e, HasCallStack)+  => e+  -> (forall t. ErrorScope t => Value t -> r)+  -> r+customErrorToVal e cont =+  case toTaggedVal e of+    (tag, SomeValue (datVal :: Value t)) ->+      -- Tags come from constructors names, so we can assume+      -- the event of weird chars occurrence to be quite improbable+      let tag' = mkMTextUnsafe tag+      in case (opAbsense (sing @t), bigMapAbsense (sing @t), contractTypeAbsense (sing @t)) of+        (Just Dict, Just Dict, Just Dict) -> cont $ VPair (VC (CvString tag'), datVal)++        -- We could check this at type-level, but this would require+        -- specializing 'Michelson.Typed.LooseSum' to errors.+        -- We can do so, or assume that no one will ever try to put 'Operation'+        -- to error datatypes:+        (Nothing, _, _) -> error "Operation in constructor data"+        (_, Nothing, _) -> error "BigMap in constructor data"+        (_, _, Nothing) -> error "Contract in constructor data"+{-# DEPRECATED customErrorToVal "Datatype error declarations has been deprecated" #-}++-- | Implementation of 'errorFromVal' for custom errors.+--+-- This function is deprecated.+customErrorFromVal+  :: forall t e.+      (SingI t, LooseSumC e)+  => Value t -> Either Text e+customErrorFromVal v = case (v, sing @t) of+  (VPair (VC (CvString tag), datVal), STPair _ _) ->+    case fromTaggedVal (toText tag, SomeValue datVal) of+      ComposeOk e ->+        Right e+      ComposeCtorNotFound ->+        Left $ "Unknown error constructor " +| tag |+ ""+      ComposeFieldTypeMismatch got expected ->+        Left $ "Error data type mismatch, expected " +|| expected ||++                                            ", got " +|| got ||+ ""+  _ -> Left $ "Expected a (tag, dat) pair representing error"+{-# DEPRECATED customErrorFromVal "Datatype error declarations has been deprecated" #-}++-- | Prompt an error message saying that 'IsoValue' is not applicable for this type.+type family CustomErrorNoIsoValue a where+  CustomErrorNoIsoValue a = TypeError+    ('Text "No IsoValue instance for " ':<>: 'ShowType a ':$$:+     'Text "It has custom error representation")++-- | Derive 'IsError' instance for given type.+--+-- This will also forbid deriving 'IsoValue' instance for that type to avoid+-- having multiple different Michelson representations.+deriveCustomError :: TH.Name -> TH.Q [TH.Dec]+deriveCustomError name =+  [d|+    instance IsError $ty where+      errorToVal = customErrorToVal+      errorFromVal = customErrorFromVal++    instance CustomErrorNoIsoValue $ty => IsoValue $ty where+      type ToT $ty = CustomErrorNoIsoValue $ty+      toVal = error "impossible"+      fromVal = error "impossible"++    instance ErrorHasDoc $ty where+      errorDocName = "Some error"+      errorDocMdCause = "An error occurred."+      errorDocHaskellRep = "-"+      errorDocClass = ErrClassUnknown+      errorDocDependencies = []+  |]+  where+    ty = pure (TH.ConT name)+{-# DEPRECATED deriveCustomError "Datatype error declarations has been deprecated" #-}+ -- | Signature of 'userFailWith'.-type UserFailInstr e name s s'-  = (InstrWrapC e name, KnownSymbol name)-  => Label name -> AppendCtorField (GetCtorField e name) s :-> s'+type FailUsingArg e name fieldTy s s'+  = ( KnownSymbol name, IsError e+    , IsoValue fieldTy+    , CtorHasOnlyField name e fieldTy, Each [Typeable, SingI] '[ToT fieldTy]+    , HasCallStack+    )+  => Label name -> fieldTy : s :-> s'  -- | Fail with given error, picking argument for error from the top--- of the stack if any required. Error will be wrapped into 'LorentzUserError'--- (i.e. an error tag will be attached to the error data).+-- of the stack. --+-- If your error constructor does not carry an argument, use 'failUsing'+-- function instead. -- Consider the following practice: once error datatype for your contract -- is defined, create a specialization of this function to the error type.-userFailWith-  :: forall err name s s'.-      (Typeable (ToT err), SingI (ToT err))-  => UserFailInstr err name s s'-userFailWith label =-  wrap_ @err @_ @s label # push (mkMTextUnsafe . toText $ symbolVal (Proxy @name)) # pair #-  coerce_ @_ @(LorentzUserError err) #+--+-- This function is deprecated.+failUsingArg+  :: forall err name fieldTy s s'.+     FailUsingArg err name fieldTy s s'+failUsingArg _ =+  push (mkMTextUnsafe ctor) #+  pair #   failWith+  where+    ctor = case symbolVal (Proxy @name) of+      'c' : other -> toText other+      other -> error $ "Bad label provided: " +| other |+ ""+{-# DEPRECATED failUsingArg "Datatype error declarations has been deprecated" #-}

@@ -0,0 +1,28 @@+{-# 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" = ()++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."

@@ -0,0 +1,139 @@+-- | By default we represent error tags using strings. This module+-- makes it possible to use numbers instead.+--+-- There are two possible ways to use it:+-- 1. If you have just one Lorentz instruction (potentially a big one),+-- just use 'useNumericErrors' function. It will change error representation+-- there and return a map that can be used to interpret new error codes.+-- 2. If your contract consists of multiple parts, start with gathering all+-- error tags ('gatherErrorTags'). Then build 'ErrorTagMap' using+-- 'addNewErrorTags'. Pass empty map if you are building from scratch+-- (you can use 'buildErrorTagMap' shortcut) or an existing+-- map if you have one (e. g. you are upgrading a contract).++module Lorentz.Errors.Numeric+  ( ErrorTagMap+  , gatherErrorTags+  , addNewErrorTags+  , buildErrorTagMap+  , applyErrorTagMap+  , useNumericErrors++  , errorFromValNumeric+  ) where++import Data.Bimap (Bimap)+import qualified Data.Bimap as Bimap+import Data.Default (def)+import qualified Data.HashSet as HS+import Data.Singletons (SingI, sing)+import Fmt (pretty)++import Lorentz.Base+import Lorentz.Errors+import Michelson.Analyzer+import Michelson.FailPattern+import Michelson.Text (MText)+import Michelson.Typed++-- | This is a bidirectional map with correspondence between numeric+-- and textual error tags.+type ErrorTagMap = Bimap Natural MText++-- | Find all textual error tags that are used in typical+-- @FAILWITH@ patterns within given instruction.+-- Map them to natural numbers.+gatherErrorTags :: inp :-> out -> HashSet MText+gatherErrorTags = HS.fromMap . void . arErrorTags . analyze . iAnyCode++-- | Add more error tags to an existing 'ErrorTagMap'. It is useful when+-- your contract consists of multiple parts (e. g. in case of contract+-- upgrade), you have existing map for some part and want to add tags+-- from another part to it.+-- You can pass empty map as existing one if you just want to build+-- 'ErrorTagMap' from a set of textual tags. See 'buildErrorTagMap'.+addNewErrorTags :: ErrorTagMap -> HashSet MText -> ErrorTagMap+addNewErrorTags existingMap newTags =+  foldl' (flip $ uncurry Bimap.tryInsert) existingMap newItems+  where+    firstUnusedNumeric+      | Bimap.null existingMap = 0+      | otherwise = fst (Bimap.findMax existingMap) + 1++    newItems :: [(Natural, MText)]+    newItems = zip [firstUnusedNumeric .. ] (toList newTags)++-- | Build 'ErrorTagMap' from a set of textual tags.+buildErrorTagMap :: HashSet MText -> ErrorTagMap+buildErrorTagMap = addNewErrorTags Bimap.empty++-- | For each typical 'FAILWITH' that uses a string to represent error+-- tag this function changes error tag to be a number using the+-- supplied conversion map.+-- It assumes that supplied map contains all such strings+-- (and will error out if it does not).+-- It will always be the case if you gather all error tags using+-- 'gatherErrorTags' and build 'ErrorTagMap' from them using 'addNewErrorTags'.+applyErrorTagMap :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out+applyErrorTagMap errorTagMap = iMapAnyCode (applyErrorTagMapT errorTagMap)++-- | This function implements the simplest scenario of using this+-- module's functionality:+-- 1. Gather all error tags from a single instruction.+-- 2. Turn them into error conversion map.+-- 3. Apply this conversion.+useNumericErrors ::+  HasCallStack => inp :-> out -> (inp :-> out, ErrorTagMap)+useNumericErrors instr = (applyErrorTagMap errorTagMap instr, errorTagMap)+  where+    errorTagMap = buildErrorTagMap $ gatherErrorTags instr++-- This function works with 'Michelson.Typed' representation, not with Lorentz.+applyErrorTagMapT ::+     HasCallStack+  => ErrorTagMap+  -> Instr inp out+  -> Instr inp out+applyErrorTagMapT errorTagMap instr =+  dfsModifyInstr dfsSettings step instr+  where+    dfsSettings :: DfsSettings ()+    dfsSettings = def+      { dsGoToValues = True+      }++    tagToNatValue :: HasCallStack => MText -> Value ('Tc 'CNat)+    tagToNatValue tag =+      case Bimap.lookupR tag errorTagMap of+        -- 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.+        Nothing -> error $ "Can't find a tag: " <> pretty tag+        Just n -> VC $ CvNat n++    step :: HasCallStack => Instr inp out -> Instr inp out+    step = modifyTypicalFailWith tagToNatValue++-- | If you apply numeric error representation in your contract, 'errorFromVal'+-- will stop working because it doesn't know about this+-- transformation.+-- This function takes this transformation into account.+-- If a number is used as a tag, but it is not found in the passed+-- map, we conservatively preserve that number (because this whole+-- approach is rather a heuristic).+errorFromValNumeric ::+  (Typeable t, SingI t, IsError e) => ErrorTagMap -> Value t -> Either Text e+errorFromValNumeric errorTagMap v =+  case v of+    VC (CvNat tag)+      | Just textualTag <- Bimap.lookup tag errorTagMap ->+        errorFromVal . VC . CvString $ textualTag+    VPair (VC (CvNat tag), something)+      | Just textualTag <- Bimap.lookup tag errorTagMap+      , _ :: Value pair <- v ->+        case sing @pair of+          STPair {} ->+            errorFromVal $ VPair (VC $ CvString textualTag, something)+    _ -> errorFromVal v

@@ -6,11 +6,12 @@   ) where  import Data.Singletons (SingI)+import GHC.TypeNats (Nat)  import Lorentz.Base import Michelson.Typed.Haskell import Michelson.Typed.Instr-import Util.Peano+import Util.Peano hiding (Nat)  stackRef   :: forall (gn :: Nat) st n.@@ -22,10 +23,11 @@ printComment = I . Ext . PRINT  testAssert-  :: Typeable (ToTs out)+  :: (Typeable (ToTs out), HasCallStack)   => Text -> PrintComment (ToTs inp) -> inp :-> Bool & out -> inp :-> inp-testAssert msg comment (I instr) =-  I . (Ext . TEST_ASSERT) $ TestAssert msg comment instr+testAssert msg comment = \case+  I instr -> I . Ext . TEST_ASSERT $ TestAssert msg comment instr+  FI _ -> error "test assert branch always fails"  stackType :: forall s. s :-> s stackType = I Nop

@@ -0,0 +1,268 @@+{- | This module contains implementation of 'Extensible' values.++@Extensible@ values are an alternative representation of sum-types+for Michelson. Instead of representing them as nested options, we+treat them as (Natural, ByteString) pair, where the first element+of the pair represents the constructor index, while the second is+a packed argument.++With such a representation sum types can be easily upgraded: it is+possible to add new elements to the sum type, and the representation+would not change.++However, such representation essentially limits the applicability of+the values. This module does not provide Michelson-level function to+unwrap the value because it would require traversing all the possible+options in the contract code. While this is possible, it is very+inefficient. Up to this moment, we have not come up with a decent+reason to allow such behavior, so Extensible types are write-only+in Michelson code. They can be unwrapped off-chain with @fromExtVal@.++In order to preserve previous values during migrations, users should+ONLY APPEND items to the underlying sum type. Changing, reordering and+deleting items is not allowed and would lead to compatibility breakage.+Currently, this restriction in not enforced. Only no-argument and+one-argument constructors are supported.++GOOD:+  -- `Extensible GoodSumTypeV1` is backwards compatible+  -- with `Extensible GoodSumTypeV2`+  data GoodSumTypeV1 = A Natural | B+  data GoodSumTypeV2 = A Natural | B | C MText++BAD:+  -- `Extensible BadSumTypeV1` is NOT backwards compatible+  -- with `Extensible BadSumTypeV2`+  data BadSumTypeV1 = A | B+  data BadSumTypeV2 = A Natural | B | C MText+-}++{-# LANGUAGE DeriveAnyClass, DerivingStrategies, InstanceSigs #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Lorentz.Extensible+  ( Extensible (..)+  , ExtConversionError (..)+  , ExtVal+  , ExtensibleHasDoc (..)+  , toExtVal+  , fromExtVal+  , wrapExt+  , WrapExtC+  ) where++import Data.Char (isSpace)+import qualified Data.Kind as Kind+import qualified Data.Text as T+import Data.Typeable (Proxy(..))+import Data.Vinyl.Derived (Label)+import Data.Vinyl.TypeLevel (type (++))+import Fmt (Buildable(build), (+||), (|+), (||+))+import GHC.Generics ((:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, Nat, Symbol)+import GHC.TypeNats (type (+))++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Instr+import Lorentz.Pack+import Michelson.Typed+import Util.Markdown+import Util.Type+import Util.TypeLits++newtype Extensible x = Extensible (Natural, ByteString)+  deriving stock (Generic, Eq, Show)+  deriving anyclass (IsoValue)++type ExtVal x = (Generic x, GExtVal x (G.Rep x))+type GetCtors x = GGetCtors (G.Rep x)++-- | Converts a value from a Haskell representation to its+--   extensible Michelson representation (i.e. (Natural, Bytestring) pair).+toExtVal :: ExtVal a => a -> Extensible a+toExtVal = gToExtVal . G.from++-- | Converts a value from an extensible Michelson representation to its+--   Haskell sum-type representation. Fails if the Michelson representation+--   points to a nun-existent constructor, or if we failed to unpack+--   the argument.+fromExtVal :: ExtVal a => Extensible a -> Either ExtConversionError a+fromExtVal val = fmap G.to $ gFromExtVal val++-- | Helper typeclass which allows us to sanely handle cases of no-arg+-- constructor and constructor with one argument.+class WrapExt (cf :: CtorField) where+  -- | Pack argument on top of the stack, if any required.+  packForWrap :: AppendCtorField cf s :-> ByteString : s++instance (NicePackedValue param) =>+         WrapExt ('OneField param) where+  packForWrap = pack++instance WrapExt 'NoFields where+  packForWrap = unit # pack++-- | Wraps an argument on top of the stack into an Extensible representation+wrapExt+  :: forall t (n :: Nat) name field s.+     (WrapExtC t n name field s)+  => Label ("c" `AppendSymbol` name) -> AppendCtorField field s :-> Extensible t ': s+wrapExt _ = packForWrap @field # push (natVal (Proxy @n)) # pair # coerce_++type WrapExtC t n name field s =+  ( 'Ctor n name field ~ LookupCtor name (EnumerateCtors (GetCtors t))+  , WrapExt field+  , KnownNat n+  )++-- | Errors related to fromExtVal conversion+data ExtConversionError+  = ConstructorIndexNotFound Natural+  | ArgumentUnpackFailed+  deriving stock (Eq, Show)++instance Buildable ExtConversionError where+  build =+    \case+      ConstructorIndexNotFound idx ->+        "Could not convert Extensible value into its Haskell representation: \+        \constructor #" +|| idx ||+ " was not found in the sum type \+        \constructors list"+      ArgumentUnpackFailed ->+        "Could not convert Extensible value into its Haskell representation: \+        \failed to unpack constructor argument"++data Position = Position Nat+data Ctor = Ctor { _n :: Nat, _name :: Symbol, _param :: CtorField }+type CtorKind = (Symbol, CtorField)++-- | Finds the constructor's position and argument type by its name+type family LookupCtor (name :: Symbol) (entries :: [Ctor])+             :: Ctor where+  LookupCtor name ('Ctor pos name param ': _) = 'Ctor pos name param+  LookupCtor name (_ ': entries) =+    LookupCtor name entries+  LookupCtor name '[] =+    TypeError ('Text "Constructor " ':<>: 'ShowType name ':<>:+               'Text " is not in the sum type constructor list")++-- | Transform list of 'CtorKind's to list of 'Ctor's, assigning numbers+-- to elements starting from 0.+type EnumerateCtors ctors = EnumerateCtorsImpl ('Position 0) ctors++type family EnumerateCtorsImpl (pos :: Position) (ctors :: [CtorKind]) :: [Ctor] where+  EnumerateCtorsImpl _ '[] = '[]+  EnumerateCtorsImpl ('Position i) ('(name, param) ': cs) =+    'Ctor i name param ': EnumerateCtorsImpl ('Position (i + 1)) cs++-- | Having a sum-type, yields a type-level list of its constructors+type family GGetCtors (x :: Kind.Type -> Kind.Type) :: [CtorKind] where+  GGetCtors (G.D1 _ x) = GGetCtors x+  GGetCtors (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param)))+    = '[ '(name, 'OneField param) ]+  GGetCtors (G.C1 ('G.MetaCons name _1 _2) G.U1)+    = '[ '(name, 'NoFields) ]+  GGetCtors (x :+: y) = GGetCtors x ++ GGetCtors y++-- | Generic implementation of toExtVal and fromExtVal+class GExtVal t (x :: Kind.Type -> Kind.Type) where+  gToExtVal :: x p -> Extensible t+  gFromExtVal :: Extensible t -> Either ExtConversionError (x p)++instance GExtVal t x => GExtVal t (G.D1 i x) where+  gToExtVal = gToExtVal @t . G.unM1+  gFromExtVal val = fmap G.M1 (gFromExtVal @t val)++instance ( 'Ctor n name 'NoFields ~ LookupCtor name (EnumerateCtors (GetCtors t))+         , KnownNat n+         )+         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) G.U1) where+  gToExtVal (G.M1 G.U1) = Extensible+    ( natVal (Proxy @n)+    , lPackValue ()+    )+  gFromExtVal (Extensible (idx, _))+    | idx == natVal (Proxy @n)+        = Right $ G.M1 G.U1+    | otherwise = Left $ ConstructorIndexNotFound idx++instance ( NiceFullPackedValue param+         , 'Ctor n name ('OneField param) ~ LookupCtor name (EnumerateCtors (GetCtors t))+         , KnownNat n+         )+         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param))) where+  gToExtVal (G.M1 (G.M1 (G.K1 param))) = Extensible+    ( natVal (Proxy @n)+    , lPackValue param+    )+  gFromExtVal (Extensible (idx, bs))+    | idx == natVal (Proxy @n)+        = first (\_ -> ArgumentUnpackFailed) $+          fmap (G.M1 . G.M1 . G.K1) $ lUnpackValue @param bs+    | otherwise = Left $ ConstructorIndexNotFound idx++instance (GExtVal t x, GExtVal t y) => GExtVal t (x :+: y) where+  gToExtVal = \case+    G.L1 x -> let Extensible val = gToExtVal @t x in Extensible val+    G.R1 y -> let Extensible val = gToExtVal @t y in Extensible val+  gFromExtVal val =+    let l = fmap G.L1 (gFromExtVal @t val)+        r = fmap G.R1 (gFromExtVal @t val)+    in l <> r++-- | Information to be provided for documenting some @'Extensible' x@.+class Typeable x => ExtensibleHasDoc x where+  -- | Implementation for 'typeDocName' of the corresponding @Extensible@.+  extensibleDocName :: Proxy x -> Text++  -- | Implementation for 'typeDocDependencies' of the corresponding @Extensible@.+  extensibleDocDependencies :: Proxy x -> [SomeTypeWithDoc]+  default extensibleDocDependencies+    :: (Generic x, GTypeHasDoc (G.Rep x))+    => Proxy x -> [SomeTypeWithDoc]+  extensibleDocDependencies = genericTypeDocDependencies++  -- | Overall description of this type.+  extensibleDocMdDescription :: Markdown++-- | Helper which documents single constructor.+class DocumentCtor (ctor :: Ctor) where+  documentCtor :: Proxy ctor -> Markdown+instance ( KnownNat pos, KnownSymbol name, TypeHasDoc param+         , param ~ ExtractCtorField field+         ) =>+         DocumentCtor ('Ctor pos name field) where+  documentCtor _ =+    natVal (Proxy @pos) |+ ": " <> mdBold (build $ symbolValT' @name) <>+    " " <> typeDocMdReference (Proxy @param) (WithinParens True)++instance ( ExtensibleHasDoc x+         , ReifyList DocumentCtor (EnumerateCtors (GetCtors x))+         ) => TypeHasDoc (Extensible x) where+  typeDocName _ = extensibleDocName (Proxy @x)+  typeDocMdReference p (WithinParens wp) =+    let name = typeDocName p+        safeName = case T.find isSpace name of+          Nothing -> name+          Just _+            | wp -> "(" <> name <> ")"+            | otherwise -> name+    in customTypeDocMdReference (safeName, DType p) [] (WithinParens False)+  typeDocDependencies _ = extensibleDocDependencies (Proxy @x)+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep+  typeDocMdDescription = mconcat+    [ extensibleDocMdDescription @x+    , "\n\n"+    , "For extensibility purposes this type is represented as `(idx, pack param)`, \+      \where `idx` is a natural number which designates constructor used to \+      \make up given value, and `param` is the argument carried in that \+      \constructor.\n\n"+    , "Value must be one of:\n\n"+    , mconcat $+        Prelude.map (<> "\n\n") $+        reifyList @Ctor @DocumentCtor @(EnumerateCtors (GetCtors x)) documentCtor+    ]

@@ -1,8 +1,12 @@ module Lorentz.Instr   ( nop   , drop+  , dropN   , dup   , swap+  , digPeano+  , dig+  , dug   , push   , some   , none@@ -19,6 +23,7 @@   , size   , emptySet   , emptyMap+  , emptyBigMap   , map   , iter   , mem@@ -32,12 +37,13 @@   , loopLeft   , lambda   , exec+  , execute+  , apply   , dip+  , ConstraintDIPNLorentz+  , dipNPeano+  , dipN   , failWith-  , failText-  , failTagged-  , failUsing-  , failUnexpected   , cast   , pack   , unpack@@ -63,7 +69,6 @@   , contract   , transferTokens   , setDelegate-  , createAccount   , createContract   , implicitAccount   , now@@ -78,24 +83,35 @@   , source   , sender   , address+  , chainId+  , framed   , LorentzFunctor (..)+  , nonZero   ) where  import Prelude hiding   (EQ, GT, LT, abs, and, compare, concat, drop, get, map, not, or, some, swap, xor) +import Data.Constraint ((\\)) import qualified Data.Kind as Kind+import Data.Singletons (SingI, sing)+import qualified GHC.TypeNats as GHC (Nat)  import Lorentz.Arith import Lorentz.Base import Lorentz.Constraints+import Lorentz.EntryPoints import Lorentz.Polymorphic+import Lorentz.Run (compileLorentzContract) import Lorentz.Value+import Lorentz.Zip import Michelson.Typed-  (Instr(..), Notes(NStar), ToT, Value'(..), checkBigMapConstraint, forbiddenBigMap,-  forbiddenOp)-import Michelson.Text+  (pattern CAR, pattern CDR, ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN',+  ConstraintDUG, ConstraintDUG', Instr(..), RemFail(..), ToTs, Value'(..), starNotes) import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Util.Peano+import Util.Type  nop :: s :-> s nop = I Nop@@ -103,15 +119,73 @@ drop :: a & s :-> s drop = I DROP +-- | Drop top @n@ elements from the stack.+dropN ::+  forall (n :: GHC.Nat) (s :: [Kind.Type]).+  -- Note: if we introduce `nPeano ~ ToPeano n` variable,+  -- GHC will complain that this constraint is redundant.+  ( SingI (ToPeano n), KnownPeano (ToPeano n)+  , RequireLongerOrSameLength (ToTs s) (ToPeano n)+  -- ↓ Kinda obvious, but not to GHC.+  , Drop (ToPeano n) (ToTs s) ~ ToTs (Drop (ToPeano n) s)+  ) => s :-> Drop (ToPeano n) s+dropN = I (DROPN $ sing @(ToPeano n))+  where+    _example :: '[ Integer, Integer, Integer ] :-> '[]+    _example = dropN @3+ dup  :: a & s :-> a & a & s dup = I DUP  swap :: a & b & s :-> b & a & s swap = I SWAP -push :: forall t s . (KnownValue t, NoOperation t, NoBigMap t, IsoValue t) => t -> (s :-> t & s)-push a = I $ forbiddenOp @(ToT t) $ forbiddenBigMap @(ToT t) $ PUSH (toVal a)+-- See a comment about `ConstraintDIPNLorentz'.+type ConstraintDIGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (a :: Kind.Type) =+  ( ConstraintDIG n (ToTs inp) (ToTs out) (ToT a)+  , ConstraintDIG' Kind.Type n inp out a+  ) +type ConstraintDUGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (a :: Kind.Type) =+  ( ConstraintDUG n (ToTs inp) (ToTs out) (ToT a)+  , ConstraintDUG' Kind.Type n inp out a+  )++-- | Version of `dig` which uses Peano number.+-- It is inteded for internal usage in Lorentz.+digPeano ::+  forall (n :: Peano) inp out a.+  ( ConstraintDIGLorentz n inp out a+  ) => inp :-> out+digPeano = I (DIG $ sing @n)++dig ::+  forall (n :: GHC.Nat) inp out a.+  ( ConstraintDIGLorentz (ToPeano n) inp out a+  ) => inp :-> out+dig = digPeano @(ToPeano n)+  where+    _example ::+      '[ Integer, Integer, Integer, Bool ] :->+      '[ Bool, Integer, Integer, Integer ]+    _example = dig @3++dug ::+  forall (n :: GHC.Nat) inp out a.+  ( ConstraintDUGLorentz (ToPeano n) inp out a+  ) => inp :-> out+dug = I (DUG $ sing @(ToPeano n))+  where+    _example ::+      '[ Bool, Integer, Integer, Integer ] :->+      '[ Integer, Integer, Integer, Bool ]+    _example = dug @3++push :: forall t s . NiceConstant t => t -> (s :-> t & s)+push a = I $ PUSH (toVal a) \\ niceConstantEvi @t+ some :: a & s :-> Maybe a & s some = I SOME @@ -123,7 +197,7 @@  ifNone   :: (s :-> s') -> (a & s :-> s') -> (Maybe a & s :-> s')-ifNone (I l) (I r) = I (IF_NONE l r)+ifNone = iGenericIf IF_NONE  pair :: a & b & s :-> (a, b) & s pair = I PAIR@@ -142,7 +216,7 @@  ifLeft   :: (a & s :-> s') -> (b & s :-> s') -> (Either a b & s :-> s')-ifLeft (I l) (I r) = I (IF_LEFT l r)+ifLeft = iGenericIf IF_LEFT  nil :: KnownValue p => s :-> List p & s nil = I NIL@@ -152,7 +226,7 @@  ifCons   :: (a & List a & s :-> s') -> (s :-> s') -> (List a & s :-> s')-ifCons (I l) (I r) = I (IF_CONS l r)+ifCons = iGenericIf IF_CONS  size :: SizeOpHs c => c & s :-> Natural & s size = I SIZE@@ -164,15 +238,19 @@          => s :-> Map k v & s emptyMap = I EMPTY_MAP +emptyBigMap :: (KnownCValue k, KnownValue v)+            => s :-> BigMap k v & s+emptyBigMap = I EMPTY_BIG_MAP+ map-  :: (MapOpHs c, IsoMapOpRes c b)+  :: (MapOpHs c, IsoMapOpRes c b, HasCallStack)   => (MapOpInpHs c & s :-> b & s) -> (c & s :-> MapOpResHs c b & s)-map (I action) = I (MAP action)+map (iNonFailingCode -> action) = I (MAP action)  iter-  :: (IterOpHs c)+  :: (IterOpHs c, HasCallStack)   => (IterOpElHs c & s :-> s) -> (c & s :-> s)-iter (I action) = I (ITER action)+iter (iNonFailingCode -> action) = I (ITER action)  mem :: MemOpHs c => MemOpKeyHs c & c & s :-> Bool & s mem = I MEM@@ -184,41 +262,98 @@ update = I UPDATE  if_ :: (s :-> s') -> (s :-> s') -> (Bool & s :-> s')-if_ (I l) (I r) = I (IF l r)+if_ = iGenericIf IF  loop :: (s :-> Bool & s) -> (Bool & s :-> s)-loop (I b) = I (LOOP b)+loop (iAnyCode -> b) = I (LOOP b)  loopLeft   :: (a & s :-> Either a b & s) -> (Either a b & s :-> b & s)-loopLeft (I b) = I (LOOP_LEFT b)+loopLeft (iAnyCode -> b) = I (LOOP_LEFT b)  lambda-  :: (KnownValue i, KnownValue o)-  => Lambda i o -> (s :-> Lambda i o & s)-lambda (I l) = I (LAMBDA $ VLam l)+  :: (ZipInstrs [i, o], KnownValue (ZippedStack i), KnownValue (ZippedStack o))+  => (i :-> o) -> (s :-> (i :-> o) & s)+lambda instr = case zippingStack instr of+  I l -> I (LAMBDA . VLam $ RfNormal l)+  FI l -> I (LAMBDA . VLam $ RfAlwaysFails l)  exec :: a & Lambda a b & s :-> b & s exec = I EXEC -dip :: forall a s s'. (s :-> s') -> (a & s :-> a & s')-dip (I a) = I (DIP a)+-- | Similar to 'exec' but works for lambdas with arbitrary size of input+-- and output.+--+-- Note that this instruction has its arguments flipped, lambda goes first.+-- This seems to be the only reasonable way to achieve good inference.+execute+  :: forall i o s.+      (Each [KnownList, ZipInstr] [i, o])+  => ((i :-> o) : (i ++ s)) :-> (o ++ s)+execute = framed @s $+  dip (zipInstr @i) # swap # I EXEC # unzipInstr @o+  where+    _example+      :: ([Integer, Natural] :-> [(), ()]) : Integer : Natural : s+      :-> () : () : s+    _example = execute +apply+  :: forall a b c s.+     (NiceConstant a)+  => a & Lambda (a, b) c & s :-> Lambda b c & s+apply = I $ APPLY \\ niceConstantEvi @a++dip :: forall a s s'. HasCallStack => (s :-> s') -> (a & s :-> a & s')+dip (iNonFailingCode -> a) = I (DIP a)++-- Helper constraint we need for 'dipN'.+-- The first constraint here is sufficient to make 'dipN' compile.+-- However, it is not enough for good type inference. If we use only the first+-- constraint, '_example' below will not compile because GHC will not be able+-- to deduce type of the input stack for 'unit'.+-- It can only deduce that 'ToTs s0' is empty (where 's0' is input stack), but+-- 'ToTs' is not injective, hence 's0' is ambiguous.+-- So we need both and we merge them into one to avoid a warning about+-- a redundant constraint.+type ConstraintDIPNLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (s :: [Kind.Type]) (s' :: [Kind.Type]) =+  ( ConstraintDIPN n (ToTs inp) (ToTs out) (ToTs s) (ToTs s')+  , ConstraintDIPN' Kind.Type n inp out s s'+  )++-- | Version of `dipN` which uses Peano number.+-- It is inteded for internal usage in Lorentz.+dipNPeano ::+  forall (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).+  ( ConstraintDIPNLorentz n inp out s s'+  ) => s :-> s' -> inp :-> out+dipNPeano (iNonFailingCode -> a) = I (DIPN (sing @n) a)++dipN ::+  forall (n :: GHC.Nat) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).+  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'+  ) => s :-> s' -> inp :-> out+dipN = dipNPeano @(ToPeano n)+  where+    _example :: '[ Integer, Integer, Integer ] :-> '[ Integer, Integer, Integer, () ]+    _example = dipN @3 unit+ failWith :: (KnownValue a) => a & s :-> t-failWith = I FAILWITH+failWith = FI FAILWITH  cast :: KnownValue a => (a & s :-> a & s) cast = I CAST  pack-  :: forall a s. (KnownValue a, NoOperation a, NoBigMap a)+  :: forall a s. (NicePackedValue a)   => a & s :-> ByteString & s-pack = I $ forbiddenOp @(ToT a) $ forbiddenBigMap @(ToT a) PACK+pack = I $ PACK \\ nicePackedValueEvi @a  unpack-  :: forall a s. (KnownValue a, NoOperation a, NoBigMap a)+  :: forall a s. (NiceUnpackedValue a)   => ByteString & s :-> Maybe a & s-unpack = I $ forbiddenOp @(ToT a) $ forbiddenBigMap @(ToT a) UNPACK+unpack = I $ UNPACK \\ niceUnpackedValueEvi @a  concat :: ConcatOpHs c => c & c & s :-> c & s concat = I CONCAT@@ -292,8 +427,8 @@ not :: UnaryArithOpHs Not n => n & s :-> UnaryArithResHs Not n & s not = I NOT -compare :: ArithOpHs Compare n m-        => n & m & s :-> ArithResHs Compare n m & s+compare :: ArithOpHs Compare n n+        => n & n & s :-> ArithResHs Compare n n & s compare = I COMPARE  eq0 :: UnaryArithOpHs Eq' n => n & s :-> UnaryArithResHs Eq' n & s@@ -317,36 +452,35 @@ int :: Natural & s :-> Integer & s int = I INT -self :: forall cp s . s :-> ContractAddr cp & s-self = I SELF+self :: forall p s . NiceParameter p => s :-> ContractRef p & s+self = I SELF \\ niceParameterEvi @p -contract :: (KnownValue p) => Address & s :-> Maybe (ContractAddr p) & s-contract = I (CONTRACT NStar)+-- TODO [TM-280]: provide proper implementation.+contract+  :: forall p s.+      (NiceParameter p)+  => Address & s :-> Maybe (ContractRef p) & s+contract = I (CONTRACT starNotes def) \\ niceParameterEvi @p  transferTokens-  :: forall p s. (KnownValue p, NoOperation p, NoBigMap p)-  => p & Mutez & ContractAddr p & s :-> Operation & s-transferTokens = I $ forbiddenOp @(ToT p) $ forbiddenBigMap @(ToT p) TRANSFER_TOKENS+  :: forall p s. (NiceParameter p)+  => p & Mutez & ContractRef p & s :-> Operation & s+transferTokens = I $ TRANSFER_TOKENS \\ niceParameterEvi @p  setDelegate :: Maybe KeyHash & s :-> Operation & s setDelegate = I SET_DELEGATE -createAccount :: KeyHash & Maybe KeyHash & Bool & Mutez & s-              :-> Operation & Address & s-createAccount = I CREATE_ACCOUNT-- createContract-  :: forall p g s. (KnownValue p, NoOperation p, KnownValue g, NoOperation g-                   , NoBigMap p, CanHaveBigMap g)-  => '[(p, g)] :-> '[(List Operation, g)]-  -> KeyHash & Maybe KeyHash & Bool & Bool & Mutez & g & s+  :: forall p g s. (NiceStorage g, ParameterEntryPoints p)+  => Contract p g+  -> Maybe KeyHash & Mutez & g & s   :-> Operation & Address & s-createContract (I c) =-  I $ forbiddenOp @(ToT p) $ forbiddenOp @(ToT g) $-  forbiddenBigMap @(ToT p) $ checkBigMapConstraint @(ToT g) $ CREATE_CONTRACT c+createContract cntrc =+  I $ CREATE_CONTRACT (compileLorentzContract cntrc)+    \\ niceParameterEvi @p+    \\ niceStorageEvi @g -implicitAccount :: KeyHash & s :-> ContractAddr () & s+implicitAccount :: KeyHash & s :-> ContractRef () & s implicitAccount = I IMPLICIT_ACCOUNT  now :: s :-> Timestamp & s@@ -373,6 +507,7 @@ hashKey :: PublicKey & s :-> KeyHash & s hashKey = I HASH_KEY +{-# WARNING stepsToQuota "STEPS_TO_QUOTA instruction is deprecated in Michelson 005" #-} stepsToQuota :: s :-> Natural & s stepsToQuota = I STEPS_TO_QUOTA @@ -385,9 +520,27 @@ sender :: s :-> Address & s sender = I SENDER -address :: ContractAddr a & s :-> Address & s+address :: ContractRef a & s :-> Address & s address = I ADDRESS +chainId :: s :-> ChainId & s+chainId = I CHAIN_ID++-- | Execute given instruction on truncated stack.+--+-- This instruction requires you to specify the piece of stack to truncate+-- as type argument.+framed+  :: forall s i o.+      (KnownList i, KnownList o)+  => (i :-> o) -> ((i ++ s) :-> (o ++ s))+framed (iNonFailingCode -> i) =+  I $ FrameInstr (Proxy @(ToTs s)) i+    \\ totsKnownLemma @i+    \\ totsKnownLemma @o+    \\ totsAppendLemma @i @s+    \\ totsAppendLemma @o @s+ ---------------------------------------------------------------------------- -- Non-canonical instructions ----------------------------------------------------------------------------@@ -418,31 +571,18 @@   -> k & UpdOpParamsHs c & c & s :-> c & s updateNew mkErr = failingWhenPresent mkErr # update --- | Fail with a given message.-failText :: MText -> s :-> t-failText msg = push msg # failWith---- | Fail with a given message and the top of the current stack.-failTagged :: (KnownValue a) => MText -> a & s :-> t-failTagged tag = push tag # pair # failWith---- | Fail with the given Haskell value.-failUsing-  :: (IsoValue a, KnownValue a, NoOperation a, NoBigMap a)-  => a -> s :-> t-failUsing err = push err # failWith---- | Fail, providing a reference to the place in the code where--- this function is called.------ Like 'error' in Haskell code, this instruction is for internal errors only.-failUnexpected :: HasCallStack => MText -> s :-> t-failUnexpected msg =-  failText $ [mt|Unexpected failure: |] <> msg <> [mt|\n|]-          <> mkMTextCut (toText $ prettyCallStack callStack)- class LorentzFunctor (c :: Kind.Type -> Kind.Type) where   lmap :: KnownValue b => (a : s :-> b : s) -> (c a : s :-> c b : s)  instance LorentzFunctor Maybe where   lmap f = ifNone none (f # some)++class NonZero t where+  -- | Retain the value only if it is not zero.+  nonZero :: t : s :-> Maybe t : s++instance NonZero Integer where+  nonZero = dup # eq0 # if_ (drop # none) some++instance NonZero Natural where+  nonZero = dup # int # eq0 # if_ (drop # none) some

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}  -- | Common Michelson macros defined using Lorentz syntax. module Lorentz.Macro@@ -31,8 +32,8 @@   -- They differ from the same macros in Michelson, because those   -- macros use FAIL macro which is not informative (fails with unit).   -- If you __really__ want Michelson versions (maybe to produce exact-  -- copy of an existing contract), you can pass empty string, then-  -- FAILWITH will be called with unit, not empty string.+  -- copy of an existing contract), you can pass 'UnspecifiedError', then+  -- FAILWITH will be called with unit.   , assert   , assertEq0   , assertNeq0@@ -53,11 +54,10 @@   , assertUsing    -- * Syntactic Conveniences-  , dipX   , dropX   , cloneX   , duupX-  , elevateX+  , framedN   , caar   , cadr   , cdar@@ -83,53 +83,71 @@   , Void_ (..)   , VoidResult(..)   , view_+  , mkView   , void_   , mkVoid++  -- * Buildable utils for additional Morley macros+  , buildView+  , buildViewTuple++  -- * Macros for working with @contract@-like types+  , pushContractRef+  , pickFutureContract   ) where  import Prelude hiding (compare, drop, some, swap)  import qualified Data.Kind as Kind import Data.Vinyl.TypeLevel (Nat(..))-import GHC.TypeNats (type (+), type (-))+import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+))+import Fmt.Internal.Tuple (TupleF)+import GHC.TypeNats (type (-)) import qualified GHC.TypeNats as GHC (Nat)  import Lorentz.Arith import Lorentz.Base-import Lorentz.Constraints import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Doc+import Lorentz.Errors+import Lorentz.Ext (stackType) import Lorentz.Instr import Lorentz.Value+import Michelson.Typed (ConstraintDIG', ConstraintDIPN', T, typeDocDependencies') import Michelson.Typed.Arith import Michelson.Typed.Haskell.Value+import Michelson.Typed (Instr (..), sepcName, starNotes)+import Util.Markdown import Util.Peano+import Util.Type  ---------------------------------------------------------------------------- -- Compare ---------------------------------------------------------------------------- -eq :: (ArithOpHs Compare n m, UnaryArithOpHs Eq' (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Eq' (ArithResHs Compare n m)) & s+eq :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Eq' (ArithResHs Compare n n)) & s eq = compare # eq0 -neq :: (ArithOpHs Compare n m, UnaryArithOpHs Neq (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Neq (ArithResHs Compare n m)) & s+neq :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Neq (ArithResHs Compare n n)) & s neq = compare # neq0 -gt :: (ArithOpHs Compare n m, UnaryArithOpHs Gt (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Gt (ArithResHs Compare n m)) & s+gt :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Gt (ArithResHs Compare n n)) & s gt = compare # gt0 -le :: (ArithOpHs Compare n m, UnaryArithOpHs Le (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Le (ArithResHs Compare n m)) & s+le :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Le (ArithResHs Compare n n)) & s le = compare # le0 -ge :: (ArithOpHs Compare n m, UnaryArithOpHs Ge (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Ge (ArithResHs Compare n m)) & s+ge :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Ge (ArithResHs Compare n n)) & s ge = compare # ge0 -lt :: (ArithOpHs Compare n m, UnaryArithOpHs Lt (ArithResHs Compare n m))-   => n & m & s :-> (UnaryArithResHs Lt (ArithResHs Compare n m)) & s+lt :: (ArithOpHs Compare n n)+   => n & n & s :-> (UnaryArithResHs Lt (ArithResHs Compare n n)) & s lt = compare # lt0  type IfCmp0Constraints a op =@@ -165,39 +183,39 @@   => (s :-> s') -> (s :-> s') -> (a & s :-> s') ifGe0 l r = ge0 # if_ l r -type IfCmpXConstraints a b op =-  (Typeable a, Typeable b, ArithOpHs Compare a b-  , UnaryArithOpHs op (ArithResHs Compare a b)-  , UnaryArithResHs op (ArithResHs Compare a b) ~ Bool)+type IfCmpXConstraints a op =+  (Typeable a, ArithOpHs Compare a a+  , UnaryArithOpHs op (ArithResHs Compare a a)+  , UnaryArithResHs op (ArithResHs Compare a a) ~ Bool)  ifEq-  :: (IfCmpXConstraints a b Eq')-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Eq')+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifEq l r = eq # if_ l r  ifNeq-  :: (IfCmpXConstraints a b Neq)-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Neq)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifNeq l r = neq # if_ l r  ifLt-  :: (IfCmpXConstraints a b Lt)-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Lt)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifLt l r = lt # if_ l r  ifGt-  :: (IfCmpXConstraints a b Gt)-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Gt)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifGt l r = gt # if_ l r  ifLe-  :: (IfCmpXConstraints a b Le)-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Le)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifLe l r = le # if_ l r  ifGe-  :: (IfCmpXConstraints a b Ge)-  => (s :-> s') -> (s :-> s') -> (a & b & s :-> s')+  :: (IfCmpXConstraints a Ge)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s') ifGe l r = ge # if_ l r  ----------------------------------------------------------------------------@@ -214,65 +232,59 @@ -- Assertions ---------------------------------------------------------------------------- --- Helper function, see Haddock comment in the export list.-assertionFailed :: MText -> whatever :-> anything-assertionFailed reason-  | null reason = fail_-  | otherwise = failText reason--assert :: MText -> Bool & s :-> s-assert reason = if_ nop (assertionFailed reason)+assert :: IsError err => err -> Bool & s :-> s+assert reason = if_ nop (failUsing reason) -assertEq0 :: IfCmp0Constraints a Eq' => MText -> a & s :-> s-assertEq0 reason = ifEq0 nop (assertionFailed reason)+assertEq0 :: (IfCmp0Constraints a Eq', IsError err) => err -> a & s :-> s+assertEq0 reason = ifEq0 nop (failUsing reason) -assertNeq0 :: IfCmp0Constraints a Neq => MText -> a & s :-> s-assertNeq0 reason = ifNeq0 nop (assertionFailed reason)+assertNeq0 :: (IfCmp0Constraints a Neq, IsError err) => err -> a & s :-> s+assertNeq0 reason = ifNeq0 nop (failUsing reason) -assertLt0 :: IfCmp0Constraints a Lt => MText -> a & s :-> s-assertLt0 reason = ifLt0 nop (assertionFailed reason)+assertLt0 :: (IfCmp0Constraints a Lt, IsError err) => err -> a & s :-> s+assertLt0 reason = ifLt0 nop (failUsing reason) -assertGt0 :: IfCmp0Constraints a Gt => MText -> a & s :-> s-assertGt0 reason = ifGt0 nop (assertionFailed reason)+assertGt0 :: (IfCmp0Constraints a Gt, IsError err) => err -> a & s :-> s+assertGt0 reason = ifGt0 nop (failUsing reason) -assertLe0 :: IfCmp0Constraints a Le => MText -> a & s :-> s-assertLe0 reason = ifLe0 nop (assertionFailed reason)+assertLe0 :: (IfCmp0Constraints a Le, IsError err) => err -> a & s :-> s+assertLe0 reason = ifLe0 nop (failUsing reason) -assertGe0 :: IfCmp0Constraints a Ge => MText -> a & s :-> s-assertGe0 reason = ifGe0 nop (assertionFailed reason)+assertGe0 :: (IfCmp0Constraints a Ge, IsError err) => err -> a & s :-> s+assertGe0 reason = ifGe0 nop (failUsing reason) -assertEq :: IfCmpXConstraints a b Eq' => MText -> a & b & s :-> s-assertEq reason = ifEq nop (assertionFailed reason)+assertEq :: (IfCmpXConstraints a Eq', IsError err) => err -> a & a & s :-> s+assertEq reason = ifEq nop (failUsing reason) -assertNeq :: IfCmpXConstraints a b Neq => MText -> a & b & s :-> s-assertNeq reason = ifNeq nop (assertionFailed reason)+assertNeq :: (IfCmpXConstraints a Neq, IsError err) => err -> a & a & s :-> s+assertNeq reason = ifNeq nop (failUsing reason) -assertLt :: IfCmpXConstraints a b Lt => MText -> a & b & s :-> s-assertLt reason = ifLt nop (assertionFailed reason)+assertLt :: (IfCmpXConstraints a Lt, IsError err) => err -> a & a & s :-> s+assertLt reason = ifLt nop (failUsing reason) -assertGt :: IfCmpXConstraints a b Gt => MText -> a & b & s :-> s-assertGt reason = ifGt nop (assertionFailed reason)+assertGt :: (IfCmpXConstraints a Gt, IsError err) => err -> a & a & s :-> s+assertGt reason = ifGt nop (failUsing reason) -assertLe :: IfCmpXConstraints a b Le => MText -> a & b & s :-> s-assertLe reason = ifLe nop (assertionFailed reason)+assertLe :: (IfCmpXConstraints a Le, IsError err) => err -> a & a & s :-> s+assertLe reason = ifLe nop (failUsing reason) -assertGe :: IfCmpXConstraints a b Ge => MText -> a & b & s :-> s-assertGe reason = ifGe nop (assertionFailed reason)+assertGe :: (IfCmpXConstraints a Ge, IsError err) => err -> a & a & s :-> s+assertGe reason = ifGe nop (failUsing reason) -assertNone :: MText -> Maybe a & s :-> s-assertNone reason = ifNone nop (assertionFailed reason)+assertNone :: IsError err => err -> Maybe a & s :-> s+assertNone reason = ifNone nop (failUsing reason) -assertSome :: MText -> Maybe a & s :-> a & s-assertSome reason = ifNone (assertionFailed reason) nop+assertSome :: IsError err => err -> Maybe a & s :-> a & s+assertSome reason = ifNone (failUsing reason) nop -assertLeft :: MText -> Either a b & s :-> a & s-assertLeft reason = ifLeft nop (assertionFailed reason)+assertLeft :: IsError err => err -> Either a b & s :-> a & s+assertLeft reason = ifLeft nop (failUsing reason) -assertRight :: MText -> Either a b & s :-> b & s-assertRight reason = ifLeft (assertionFailed reason) nop+assertRight :: IsError err => err -> Either a b & s :-> b & s+assertRight reason = ifLeft (failUsing reason) nop  assertUsing-  :: (IsoValue a, KnownValue a, NoOperation a, NoBigMap a)+  :: IsError a   => a -> Bool & s :-> s assertUsing err = if_ nop $ failUsing err @@ -280,42 +292,15 @@ -- Syntactic Conveniences ---------------------------------------------------------------------------- -type family Above (n :: Peano) s where-  Above  'Z _s = '[]-  Above ('S n) (a ': s) = (a ': Above n s)--class DipX (n :: Peano) (head :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]) where-  dipXImpl :: s :-> s' -> head ++ s :-> head ++ s'-instance DipX 'Z '[] s s' where-  dipXImpl op = op-instance DipX n h s s' => DipX ('S n) (a ': h) s s' where-  dipXImpl = dip . dipXImpl @n @h---- Type family, that is necessary for DipX-type family (++) (l :: [a]) (r :: [a]) where-  '[] ++ r = r-  (l ': ls) ++ r = l ': (ls ++ r)---- | @DII+P@ macro. For example, `dipX @3` is `DIIIP`.-dipX-  :: forall (n :: GHC.Nat) inp out s s'.-  (DipX (ToPeano n) (Above (ToPeano n) inp) s s'-  , ((Above (ToPeano n) inp) ++ s) ~ inp-  , ((Above (ToPeano n) inp) ++ s') ~ out)-  => (s :-> s') -> inp :-> out-dipX = dipXImpl @(ToPeano n) @(Above (ToPeano n) inp)- -- | 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'.-  ( DipX (ToPeano n) (Above (ToPeano n) inp) s s'-  , ((Above (ToPeano n) inp) ++ s) ~ inp-  , ((Above (ToPeano n) inp) ++ s') ~ out+  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'   , s ~ (a ': s')   )   => inp :-> out-dropX = dipX @n @inp @out @s @s' drop+dropX = dipN @n @inp @out @s @s' drop  class CloneX (n :: Peano) a s where   type CloneXT n a s :: [Kind.Type]@@ -335,43 +320,81 @@   => a & s :-> CloneXT (ToPeano n) a s cloneX = cloneXImpl @(ToPeano n) -class DuupX (n :: Peano) (s :: [Kind.Type]) (a :: Kind.Type) where-  duupXImpl :: s :-> a & s+-- | Kind-agnostic constraint for duupX+type DuupXConstraint' kind (n :: Peano)+  (s :: [kind]) (a :: kind) (s1 :: [kind]) (tail :: [kind]) =+  ( tail ~ Drop ('S n) s+  , ConstraintDIPN' kind n s s1 (a ': tail) (a ': a ': tail)+  , ConstraintDIG' kind n s1 (a ': s) a+  ) -instance DuupX ('S 'Z) (a & xs) a where+-- | Constraint for duupX that combines kind-agnostic constraint for+-- Lorentz (Haskell) types and for our typed Michelson.+type ConstraintDuupXLorentz (n :: Peano)+  (s :: [Kind.Type]) (a :: Kind.Type)+  (s1 :: [Kind.Type]) (tail :: [Kind.Type]) =+  ( DuupXConstraint' T n (ToTs s) (ToT a) (ToTs s1) (ToTs tail)+  , DuupXConstraint' Kind.Type n s a s1 tail+  )++class DuupX (n :: Peano) (s :: [Kind.Type]) (a :: Kind.Type) s1 tail where+  duupXImpl :: s :-> a ': s++instance {-# OVERLAPPING #-} (s ~ (a ': xs)) => DuupX ('S 'Z) s a s1 tail where   duupXImpl = dup -instance DuupX ('S n) xs a => DuupX ('S ('S n)) (x & xs) a where-  duupXImpl = dip (duupXImpl @('S n) @xs @a) # swap+instance {-# OVERLAPPING #-} DuupX ('S ('S 'Z)) (b ': a ': xs) a s1 tail where+  duupXImpl = dip dup # swap +instance {-# OVERLAPPABLE #-} (ConstraintDuupXLorentz ('S ('S n)) s a s1 tail) =>+  DuupX ('S ('S ('S n))) s a s1 tail where+  duupXImpl =+    -- 'stackType' helps GHC deduce types+    dipNPeano @('S ('S n)) (dup # stackType @(a ': a ': tail)) #+    digPeano @('S ('S n))+ -- | @DUU+P@ macro. For example, `duupX @3` is `DUUUP`, it puts -- the 3-rd (starting from 1) element to the top of the stack.-duupX-  :: forall (n :: GHC.Nat) inp .-  ( DuupX (ToPeano n) inp (At (ToPeano (n - 1)) inp)+-- Note that it is implemented differently for `n ≤ 2` and for `n > 2`.+-- In the latter case it is implemented using `dipN`, `dig` and `dup`.+-- In the former case it uses specialized versions.+-- There is also a minor difference with the implementation of `DUU*P` in+-- Michelson.+-- They implement `DUUUUP` as `DIP 3 { DUP }; DIG 4`.+-- We implement it as `DIP 3 { DUP }; DIG 3`. These are equivalent.+-- Our version is supposedly cheaper, at least it should be packed+-- more efficiently due to the way numbers are packed.+duupX :: forall (n :: GHC.Nat) a (s :: [Kind.Type]) (s1 :: [Kind.Type]) (tail :: [Kind.Type]).+  ( ConstraintDuupXLorentz (ToPeano (n - 1)) s a s1 tail+  , DuupX (ToPeano n) s a s1 tail   )-  => inp :-> (At (ToPeano (n - 1)) inp) & inp-duupX = duupXImpl @(ToPeano n) @inp @(At (ToPeano (n - 1)) inp)+  => s :-> a ': s+duupX = duupXImpl @(ToPeano n) @s @a @s1 @tail+  where+    _example ::+      '[ Integer, (), Bool ] :->+      '[ Bool, Integer, (), Bool ]+    _example = duupX @3 --- | Move item with given index (starting from 0) to the top of the stack.+-- | Version of 'framed' which accepts number of elements on input stack+-- which should be preserved. ----- TODO: probably it can be implemented more efficiently, so if we--- ever want to optimize gas consumption we can rewrite it.--- It only makes sense if it's applied to a relatively large index.-elevateX-  :: forall (n :: GHC.Nat) inp out s a.-  ( DuupX (ToPeano (1 + n)) inp a-  , DipX (ToPeano (n + 1)) (Above (ToPeano (n + 1)) (a : inp)) (a : s) s-  , (a ': (Above (ToPeano n) inp) ++ s) ~ out-  , a ~ At (ToPeano n) inp--  -- These 3 constraints must hold if the above holds, but GHC can't deduce it.-  -- Btw, last constraint must always hold.-  , (Above (ToPeano (n + 1)) (a ': inp) ++ (a ': s)) ~ (a ': inp)-  , (Above (ToPeano (n + 1)) (a : inp) ++ s) ~ (a : (Above (ToPeano n) inp ++ s))-  , ((1 + n) - 1) ~ n-  ) => inp :-> out-elevateX = duupX @(1 + n) @inp # dropX @(n + 1) @a @(a ': inp) @out @(a ': s) @s+-- You can treat this macro as calling a Michelson function with given number+-- of arguments.+framedN+  :: forall n nNat s i i' o o'.+     ( nNat ~ ToPeano n+     , i' ~ Take nNat i, s ~ Drop nNat i+     , i ~ (i' ++ s), o ~ (o' ++ s)+     , KnownList i', KnownList o'+     )+  => (i' :-> o') -> (i :-> o)+framedN = framed @s+  where+  _example+    :: [Integer, Natural] :-> '[ByteString]+    -> Integer : Natural : () : s :-> ByteString : () : s+  _example = framedN @2  papair :: a & b & c & s :-> ((a, b), c) & s papair = pair # pair@@ -476,17 +499,49 @@ -- | @view@ type synonym as described in A1. data View (a :: Kind.Type) (r :: Kind.Type) = View   { viewParam :: a-  , viewCallbackTo :: ContractAddr (a, Maybe r)-  } deriving stock Generic+  , viewCallbackTo :: ContractRef r+  } deriving stock (Eq, Show, Generic)     deriving anyclass IsoValue +instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View a r) where+  typeDocMdDescription =+    "`View a r` accepts an argument of type `a` and callback contract \+    \which accepts `r` and returns result via calling that contract.\n\+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/blob/master/A/A1.md#view-entry-points)."+  typeDocMdReference = poly2TypeDocMdReference+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+  typeDocHaskellRep =+    haskellRepNoFields $ concreteTypeDocHaskellRep @(View () Integer)+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @(View () Integer)++instance {-# OVERLAPPABLE #-} Buildable a => Buildable (View a r) where+  build = buildView build++instance {-# OVERLAPPING  #-} Buildable (View () r) where+  build = buildView $ const "()"+++buildViewTuple :: TupleF a => View a r -> Builder+buildViewTuple = buildView tupleF++buildView :: (a -> Builder) -> View a r -> Builder+buildView bfp (View {..}) =+  "(View param: " +| bfp viewParam |+ " callbackTo: " +| viewCallbackTo|+ ")"++-- | Polymorphic version of 'View' constructor.+mkView :: ToContractRef r contract => a -> contract -> View a r+mkView a c = View a (toContractRef c)+ view_ ::-     (KnownValue a, KnownValue r, NoOperation (a, r), NoBigMap (a, r))+     (NiceParameter r)   => (forall s0. (a, storage) & s0 :-> r : s0)   -> View a r & storage & s :-> (List Operation, storage) & s view_ code =   coerce_ #-  unpair # dip (duupX @2) # dup # dip (pair # code # some) # pair # dip amount #+  unpair # dip (duupX @2) # pair # code # dip amount #   transferTokens # nil # swap # cons # pair  -- | @void@ type synonym as described in A1.@@ -498,21 +553,121 @@   } deriving stock Generic     deriving anyclass IsoValue +instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (Void_ a r) where+  typeDocName _ = "Void"+  typeDocMdDescription =+    "`Void a r` accepts an argument of type `a` and returns a value of type \+    \`r` as contract error. To comply with general mechanism of contracts \+    \custom errors, void entrypoints execute `FAILWITH` instruction on \+    \`(\"VoidResult\", r)` value, where `r` is the actual return value of the \+    \entrypoint.\n\+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/blob/master/A/A1.md#void-entry-points)."+  typeDocMdReference tp =+    -- Avoiding trailing underscore+    customTypeDocMdReference+      ("Void", DType tp)+      [ DType (Proxy @a)+      , DType (Proxy @r)+      ]+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+  typeDocHaskellRep p = do+    (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ () Integer)) p+    return (Just "Void () Integer", rhs)+  typeDocMichelsonRep p =+    let (_, rhs) = concreteTypeDocMichelsonRep @(Void_ () Integer) p+    in (Just "Void () Integer", rhs)++instance Buildable a => Buildable (Void_ a b) where+  build Void_ {..} = "(Void param: " +| voidParam |+ ")"+ -- | Newtype over void result type used in tests to -- distinguish successful void result from other errors. -- -- Usage example: -- lExpectFailWith (== VoidResult roleMaster)`+--+-- This error is special - it can contain arguments of different types+-- depending on entrypoint which raises it. newtype VoidResult r = VoidResult { unVoidResult :: r }-  deriving newtype (Eq, IsoValue)+  deriving stock (Generic)+  deriving newtype (Eq) +voidResultTag :: MText+voidResultTag = [mt|VoidResult|]++type VoidResultRep r = (MText, r)++instance (TypeHasDoc r, IsError (VoidResult r)) => TypeHasDoc (VoidResult r) where+  typeDocMdDescription = typeDocMdDescriptionReferToError @(VoidResult r)+  typeDocMdReference = poly1TypeDocMdReference+  typeDocHaskellRep = concreteTypeDocHaskellRepUnsafe @(VoidResultRep Integer)+  typeDocMichelsonRep = concreteTypeDocMichelsonRepUnsafe @(VoidResultRep Integer)++instance (Typeable r, NiceConstant r, ErrorHasDoc (VoidResult r)) =>+         IsError (VoidResult r) where+  errorToVal (VoidResult e) cont =+    withDict (niceConstantEvi @r) $+    isoErrorToVal @(VoidResultRep r) (voidResultTag, e) cont+  errorFromVal fullErr =+    isoErrorFromVal fullErr >>= \((tag, e) :: VoidResultRep r) ->+      if tag == voidResultTag+      then pure $ VoidResult e+      else Left $ "Error mismatch, expected VoidResult, got " <> pretty tag++instance TypeHasDoc r => ErrorHasDoc (VoidResult r) where+  errorDocName = "VoidResult"+  errorDocMdCause =+    "Call to entrypoint has succeeded, reporting returned value as error.\n\+    \As Tezos contracts normally do not produce any output (not counting storage \+    \update), this is the simplest way to return something to the caller in \+    \read-only entrypoints."+  errorDocHaskellRep =+    mdTicked ("(\"" <> pretty (voidResultTag) <> "\", " <> "<return value>" <> ")")+  errorDocDependencies =+    typeDocDependencies' (Proxy @MText) <> typeDocDependencies' (Proxy @r)++instance CustomErrorNoIsoValue (VoidResult r) => IsoValue (VoidResult r) where+  type ToT (VoidResult r) = CustomErrorNoIsoValue (VoidResult r)+  toVal = error "impossible"+  fromVal = error "impossible"+ mkVoid :: forall b a. a -> Void_ a b mkVoid a = Void_ a nop  void_   :: forall a b s s' anything.-      (KnownValue b)+      (IsError (VoidResult b), KnownValue b)   => a & s :-> b & s' -> Void_ a b & s :-> anything void_ code =+  doc (DThrows (Proxy @(VoidResult b))) #   coerce_ @_ @(_, Lambda b b) #-  unpair # swap # dip code # swap # exec # coerce_ @b @(VoidResult b) # failWith+  unpair # swap # dip code # swap # exec #+  push voidResultTag # pair # failWith @(MText, b)++-- | Turn 'FutureContract' into actual 'contract'.+--+-- This requires contracts lookup and may fail.+pickFutureContract+  :: NiceParameter p+  => FutureContract p : s :-> Maybe (ContractRef p) : s+pickFutureContract = coerce_ # contract++-- | Push a value of @contract@ type.+--+-- Doing this via 'push' instruction is not possible, so we need to perform+-- extra actions here.+--+-- Aside from @contract@ value itself you will need to specify which error to+-- throw in case this value is not valid.+pushContractRef+  :: NiceParameter arg+  => (forall s0. Address : s :-> s0)+  -> ContractRef arg+  -> (s :-> ContractRef arg : s)+pushContractRef onContractNotFound (ContractRef addr sepc :: ContractRef arg) =+  withDict (niceParameterEvi @arg) $+    push addr # dup #+    I (CONTRACT starNotes (sepcName sepc)) #+    ifNone onContractNotFound (dip drop)