indigo 0.5.0 → 0.6.0

raw patch · 75 files changed

+5195/−4503 lines, 75 filesdep +data-defaultdep +filepathdep +reqdep −summonernew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, filepath, req, time, tree-view, universum

Dependencies removed: summoner

API changes (from Hackage documentation)

Files

• CHANGES.md +46/−0
• LICENSE +3/−1
• README.md +4/−0
• app/FileGen.hs +17/−13
• app/FileGen/Files.hs +68/−44
• app/FileGen/Tree.hs +46/−0
• app/Helper.hs +15/−1
• app/Main.hs +85/−124
• app/Upgrade.hs +75/−0
• indigo.cabal +179/−26
• snapshots/indigo-dependence-snapshot.yaml +0/−11
• snapshots/indigo-snapshot.yaml +51/−23
• src/Indigo.hs +11/−6
• src/Indigo/Backend.hs +48/−21
• src/Indigo/Backend/Case.hs +13/−10
• src/Indigo/Backend/Conditional.hs +12/−9
• src/Indigo/Backend/Error.hs +28/−14
• src/Indigo/Backend/Expr/Compilation.hs +360/−0
• src/Indigo/Backend/Expr/Decompose.hs +143/−0
• src/Indigo/Backend/Lambda.hs +29/−20
• src/Indigo/Backend/Lookup.hs +359/−0
• src/Indigo/Backend/Scope.hs +11/−12
• src/Indigo/Backend/Var.hs +16/−8
• src/Indigo/Common/Expr.hs +520/−0
• src/Indigo/Common/Expr/TH.hs +165/−0
• src/Indigo/Common/Field.hs +136/−0
• src/Indigo/Common/Object.hs +211/−0
• src/Indigo/Common/SIS.hs +55/−0
• src/Indigo/Common/State.hs +247/−0
• src/Indigo/Common/Var.hs +157/−0
• src/Indigo/Compilation.hs +8/−5
• src/Indigo/Compilation/Field.hs +1/−1
• src/Indigo/Compilation/Hooks.hs +6/−7
• src/Indigo/Compilation/Lambda.hs +4/−2
• src/Indigo/Compilation/Params.hs +7/−7
• src/Indigo/Compilation/Sequential.hs +17/−348
• src/Indigo/Compilation/Sequential/Types.hs +373/−0
• src/Indigo/Frontend.hs +9/−0
• src/Indigo/Frontend/Expr.hs +883/−0
• src/Indigo/Frontend/Internal/Statement.hs +222/−0
• src/Indigo/Frontend/Language.hs +97/−46
• src/Indigo/Frontend/Program.hs +4/−3
• src/Indigo/Frontend/Statement.hs +0/−202
• src/Indigo/Internal.hs +0/−15
• src/Indigo/Internal/Expr.hs +0/−15
• src/Indigo/Internal/Expr/Compilation.hs +0/−349
• src/Indigo/Internal/Expr/Decompose.hs +0/−141
• src/Indigo/Internal/Expr/Symbolic.hs +0/−835
• src/Indigo/Internal/Expr/TH.hs +0/−130
• src/Indigo/Internal/Expr/Types.hs +0/−506
• src/Indigo/Internal/Field.hs +0/−135
• src/Indigo/Internal/Lookup.hs +0/−377
• src/Indigo/Internal/Object.hs +0/−183
• src/Indigo/Internal/SIS.hs +0/−54
• src/Indigo/Internal/State.hs +0/−247
• src/Indigo/Internal/Var.hs +0/−155
• src/Indigo/Lib.hs +9/−8
• src/Indigo/Lorentz.hs +18/−10
• src/Indigo/Prelude.hs +5/−7
• src/Indigo/Print.hs +15/−11
• src/Indigo/Rebinded.hs +0/−86
• src/Indigo/Rebound.hs +86/−0
• test/Main.hs +3/−4
• test/Test/Code/Decomposition.hs +9/−6
• test/Test/Code/Examples.hs +34/−12
• test/Test/Code/Expr.hs +3/−7
• test/Test/Code/Lambda.hs +10/−11
• test/Test/DebugComments.hs +10/−11
• test/Test/Decomposition.hs +14/−18
• test/Test/Examples.hs +93/−44
• test/Test/Expr.hs +40/−38
• test/Test/Lambda.hs +30/−21
• test/Test/Lookup.hs +9/−12
• test/Test/Util.hs +59/−85
• test/Test/Util/Golden.hs +7/−6

@@ -1,3 +1,49 @@+Unreleased+==========+<!-- Append new entries here -->+* [!43](https://gitlab.com/morley-framework/indigo/-/merge_requests/43)+  Add emit instruction+  + New user-facing function `Indigo.Frontend.Language.emit` to emit contract+    events.+  + `annQ` and `FieldAnn` are re-exported from `Indigo.Frontend.Language` and+    consequently `Indigo`.+* [!42](https://gitlab.com/morley-framework/indigo/-/merge_requests/42)+  Updates for kathmandu+  + Bump dependencies+  + Fix typo in "division by zero" error text (was "devision by zero") in the+    expression code generator.+* [!41](https://gitlab.com/morley-framework/indigo/-/merge_requests/41)+  Updates for jakarta and GHC-9+  + Bump dependencies+  + Bump compiler/stack resolver+  + Bump docker base image+  + Note that due to Jakarta changes, some functions may need `IsNotInView`+    constraint now, exported from `Indigo.Lorentz` and `Indigo`.+* [!35](https://gitlab.com/morley-framework/indigo/-/merge_requests/35)+  Add upgrade command; generate indigo-dependency-snapshot.yaml on demand+  + Add an `indigo upgrade` command, building the latest indigo version+  + Also update project generator for latest indigo/morley+* [!36](https://gitlab.com/morley-framework/indigo/-/merge_requests/36)+  Reorganize Indigo modules+  - Get rid of `Indigo.Internal` and `Indigo.Internal.Expr` "god modules"+  - Several moves:+      - `Indigo.Internal.Lookup`, `Indigo.Internal.Expr.Compilation`, `Indigo.Internal.Expr.Decompose` to `Indigo.Backend.*`+      - `Indigo.Internal.Expr.Symbolic` to `Indigo.Frontend.Expr`+      - `Indigo.Frontend.Statement` to `Indigo.Frontend.Internal.Statement` (it's not reexported)+      - `Indigo.Common.Expr.Types` to `Indigo.Common.Expr`+  - Do not re-export backend parts from `Indigo`, specifically, `Indigo.Backend.Expr.*` and `Indigo.Backend.Lookup`+  - Rename `Indigo.Internal.*` to `Indigo.Common.*` (not really internal, since it's exported from `Indigo`)+  - Rename `Indigo.Rebinded` to `Indigo.Rebound`+  - Split type definitions from `Indigo.Compilation.Sequential` into `Indigo.Compilation.Sequential.Types`+* [!34](https://gitlab.com/morley-framework/indigo/-/merge_requests/34)+  Replace `dip dip` with `dip 2` in the code generator+* [!24](https://gitlab.com/morley-framework/indigo/-/merge_requests/24)+  Bump Morley/Lorentz and comply with the changes in them.+* [!15](https://gitlab.com/morley-framework/indigo/-/merge_requests/15)+  Add `failCustomNoArg` which allows failing with just a string instead of `pair string <arg>`.+* [!18](https://gitlab.com/morley-framework/indigo/-/merge_requests/18)+  Bump over Morley/Lorentz with all the edo functionality (but tickets are not yet supported).+ 0.5.0 ========== * [!12](https://gitlab.com/morley-framework/indigo/-/merge_requests/12)

@@ -1,4 +1,6 @@-MIT License Copyright (c) 2020 Tocqueville Group+MIT License+Copyright (c) 2021-2022 Oxhead Alpha+Copyright (c) 2019-2021 Tocqueville Group  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -1,3 +1,7 @@+> :warning: **Note: this project is being deprecated.**+>+> It will no longer be maintained after the activation of protocol "N" on the Tezos mainnet.+ # Indigo eDSL  [![Hackage](https://img.shields.io/hackage/v/indigo.svg)](https://hackage.haskell.org/package/indigo)

@@ -1,37 +1,37 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | File Generation machinery that resembles @summoner@ library. module FileGen   ( run   ) where +import FileGen.Tree (FsTree(..), drawFsTree, makeFS) import System.Directory (setCurrentDirectory)-import Summoner.Tree (TreeFs(..), showBoldTree, traverseTree) -import qualified FileGen.Files as F+import FileGen.Files qualified as F+import Paths_indigo (version) -run :: Text -> IO ()-run projectName =-  createProjectDirectoryCustom (CustomSettings projectName)+run :: Text -> Maybe Text -> IO ()+run projectName gitRev =+  createProjectDirectoryCustom (CustomSettings projectName gitRev)  -- | From the given 'CustomSettings' creates the project. createProjectDirectoryCustom :: CustomSettings -> IO () createProjectDirectoryCustom settings@CustomSettings{..} = do   let tree = createProjectTemplateCustom settings-  traverseTree tree+  makeFS "." tree   putTextLn "The project with the following structure has been created:"-  putTextLn $ showBoldTree tree+  drawFsTree tree   setCurrentDirectory (toString sProjectName)  -- | Creating tree structure of the project.-createProjectTemplateCustom :: CustomSettings -> TreeFs+createProjectTemplateCustom :: CustomSettings -> FsTree createProjectTemplateCustom settings@CustomSettings{..} =   Dir (toString sProjectName) $ generateFiles settings  -- | Files Template-generateFiles :: CustomSettings -> [TreeFs]+generateFiles :: CustomSettings -> [FsTree] generateFiles CustomSettings{..} =   [ Dir "app"       [ File "Main.hs" F.main ]@@ -41,6 +41,7 @@       [ Dir "Test"           [ File "Basic.hs" F.basicTest ]       , File "Main.hs" F.mainTest+      , File "Tree.hs" F.treeTest       ]   , File "ChangeLog.md" (F.changelog sProjectName)   , File "README.md" (F.readme sProjectName)@@ -48,9 +49,12 @@   , File "package.yaml" (F.packageYaml sProjectName)   , File "stack.yaml" F.stackYaml   , File "indigo-snapshot.yaml" F.indigoSnapshotYaml-  , File "indigo-dependence-snapshot.yaml" F.indigoDependenceSnapshotYaml+  , File "indigo-dependence-snapshot.yaml" $+      F.indigoDependenceSnapshotYaml $+        maybe (F.DSVPublishedVersion version) F.DSVGitCommitSha sGitRev   ]  data CustomSettings = CustomSettings   { sProjectName :: Text+  , sGitRev :: Maybe Text   }

@@ -1,12 +1,12 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | List of functions that generate the files for 'FileGen'. module FileGen.Files   ( main   , basic   , mainTest+  , treeTest   , basicTest   , changelog   , readme@@ -15,10 +15,15 @@   , stackYaml   , indigoSnapshotYaml   , indigoDependenceSnapshotYaml+  , DependenceSnapshotVersion(..)   ) where  import Data.FileEmbed (embedStringFile) import Data.String.Interpolate (i)+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Version (Version, showVersion)+import System.IO.Unsafe (unsafePerformIO)  import Helper @@ -79,8 +84,8 @@ import Indigo import Lorentz.Run (Contract) -basicContractLorentz :: Contract Integer Integer-basicContractLorentz = defaultContract $ compileIndigoContract basicContract+basicContractLorentz :: Contract Integer Integer ()+basicContractLorentz = mkContract $ compileIndigoContract basicContract  basicContract :: IndigoContract Integer Integer basicContract param = defContract do@@ -95,47 +100,48 @@  basicTest :: Text basicTest = [i|module Test.Basic-  ( unit_updates_storage_properly+  ( test_updates_storage_properly   ) where  import Basic (basicContractLorentz) -import Lorentz-import Lorentz.Test-import Michelson.Test.Integrational-import Michelson.Typed.Convert-import Test.Tasty.HUnit (Assertion)+import Test.Tasty (TestTree) -unit_updates_storage_properly :: Assertion-unit_updates_storage_properly = integrationalTestExpectation $ do-  contractAddr <- originate (convertContract $ compileLorentzContract basicContractLorentz) "basic"-          (untypeValue $ toVal (10 :: Integer)) (zeroMutez)+import Test.Cleveland -  let-    txData = TxData-      { tdSenderAddress = genesisAddress-      , tdParameter = TxTypedParam $ toVal (90 :: Integer)-      , tdEntrypoint = DefEpName-      , tdAmount = zeroMutez-      }+test_updates_storage_properly :: TestTree+test_updates_storage_properly = testScenario "Basic test" $ scenario do+  contractAddr <- originate "basic" (10 :: Integer) basicContractLorentz -  transfer txData contractAddr+  transfer contractAddr $ calling def 90 -  expectStorageConst contractAddr-    $ untypeValue $ toVal (100 :: Integer)+  getStorage contractAddr @@== 100+ |] +treeTest :: Text+treeTest =+  "{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF \+  \--generated-module -optF Tree #-}\n"+ mainTest :: Text-mainTest = "{-# OPTIONS_GHC -F -pgmF tasty-discover #-}\n"+mainTest = [i|module Main (main) where +import Test.Cleveland.Tasty+import Tree (tests)++main :: IO ()+main = tests >>= clevelandMain+|]+ changelog :: Text -> Text-changelog projectName = [i|# Changelog for #{projectName}+changelog projectName = [i|\# Changelog for #{projectName} -## Unreleased changes+\#\# Unreleased changes |]  readme :: Text -> Text-readme projectName = [i|# #{projectName}+readme projectName = [i|\# #{projectName} |]  gitignore :: Text@@ -156,7 +162,7 @@ - README.md - ChangeLog.md -description:         Please see the README on GitHub at <https://github.com/githubuser/#{projectName}#readme>+description:         Please see the README on GitHub at <https://github.com/githubuser/#{projectName}\#readme>  verbatim:   cabal-version: 2.2@@ -222,6 +228,8 @@   - -Wno-missing-local-signatures   - -Wno-monomorphism-restriction   - -Wno-implicit-prelude+  - -Wno-missing-safe-haskell-mode+  - -Wno-prepositive-qualified-module  library:   source-dirs: src@@ -232,11 +240,8 @@     - Paths_#{useUnderscore projectName}    dependencies:-    - containers-    - fmt     - indigo     - lorentz-    - morley     - text  executables:@@ -249,7 +254,6 @@       - containers       - morley       - lorentz-      - indigo       - optparse-applicative       - universum       - with-utf8@@ -267,16 +271,8 @@     dependencies:       - #{projectName}       - cleveland-      - containers-      - fmt-      - hspec-      - hspec-expectations-      - HUnit       - lorentz-      - morley       - tasty-      - tasty-hspec-      - tasty-hunit-compat |]  stackYaml :: Text@@ -293,5 +289,33 @@ indigoSnapshotYaml :: Text indigoSnapshotYaml = $(embedStringFile "./snapshots/indigo-snapshot.yaml") -indigoDependenceSnapshotYaml :: Text-indigoDependenceSnapshotYaml = $(embedStringFile "./snapshots/indigo-dependence-snapshot.yaml")+data DependenceSnapshotVersion+  = DSVGitCommitSha Text+  | DSVPublishedVersion Version++indigoDependenceSnapshotYaml :: DependenceSnapshotVersion -> Text+indigoDependenceSnapshotYaml dsv = [i|+\# SPDX-FileCopyrightText: #{year} Oxhead Alpha+\# SPDX-License-Identifier: LicenseRef-MIT-OA++name: indigo-dependence-snapshot++\# See more extra-deps in 'indigo-snapshot.yaml'.+resolver: indigo-snapshot.yaml++\# The 'packages' here act as 'extra-deps'.+packages:#{package}|]+  where+    package :: Text+    package = case dsv of+      DSVGitCommitSha rev -> [i|+- git: https://gitlab.com/morley-framework/indigo.git+  commit: #{rev}+|]+      DSVPublishedVersion ver -> [i|+- indigo-#{showVersion ver}+|]+    -- we're just reading system clock here, this is pretty safe;+    -- besides, we're only calling this once per run, so sharing caveats+    -- don't apply;+    year = unsafePerformIO $ formatTime defaultTimeLocale "%Y" <$> getCurrentTime

@@ -0,0 +1,46 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# LANGUAGE ViewPatterns #-}++module FileGen.Tree+       ( FsTree (..)+       , makeFS+       , drawFsTree+       ) where++import Data.Tree (Tree(..))+import Data.Tree.View (drawTree)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Universum.Lifted.File (writeFile)++-- | Represents a filesystem directory tree description, with 'Text' files.+data FsTree+  = Dir -- ^ A directory+      String -- ^ The name of the directory+      [FsTree] -- ^ The forest of directory contents+  | File -- ^ A text file+      String -- ^ The name of the file+      Text -- ^ File content++-- | Create files and directories from 'FsTree' description.+makeFS+  :: FilePath -- ^ Path to the root directory of the tree+  -> FsTree -- ^ The tree description+  -> IO ()+makeFS root = \case+  File name content -> do+    writeFile (root </> name) content+  Dir name sub -> do+    let path = root </> name+    createDirectoryIfMissing True path+    mapM_ (makeFS path) sub++-- | Output the unicode-art representation of 'FsTree' to stdout.+drawFsTree :: FsTree -> IO ()+drawFsTree = drawTree . toStringTree+  where+    toStringTree = \case+      File name _ -> Node name []+      Dir name sub -> Node name $ toStringTree <$> sub

@@ -11,10 +11,15 @@   , indigoTitle   , indigoDesc   , indigoRunCommand+  , repo+  , doesExistProjectName   ) where +import Data.Text qualified as T+import Network.HTTP.Req (Scheme(Https), Url, https, (/:)) import Prelude hiding (many)-import qualified Data.Text as T+import System.Directory (doesPathExist, getCurrentDirectory)+import System.FilePath ((</>)) import Text.Megaparsec (Parsec, eof, many, runParser, sepBy1) import Text.Megaparsec.Char (char, digitChar, letterChar) @@ -61,3 +66,12 @@ -- Mainly use to manipulate package name. useUnderscore :: Text -> Text useUnderscore = T.replace "-" "_"++repo :: Text -> Url 'Https+repo revision = https "gitlab.com" /: "morley-framework" /: "indigo" /: "-"+  /: "raw" /: revision++doesExistProjectName :: Text -> IO Bool+doesExistProjectName projectName = do+  curPath <- getCurrentDirectory+  doesPathExist $ curPath </> toString projectName

@@ -1,162 +1,93 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Main   ( main   ) where  import Data.Text (dropWhileEnd)-import qualified Data.Text.IO.Utf8 as Utf8+import Data.Text.IO.Utf8 qualified as Utf8 import Data.Version (showVersion) import Options.Applicative-  (command, execParser, fullDesc, header, help, helper, info, infoOption, long, progDesc,-  subparser)-import qualified Options.Applicative as Opt+  (command, execParser, fullDesc, header, help, helper, info, infoOption, long, progDesc, subparser)+import Options.Applicative qualified as Opt import Paths_indigo (version)-import qualified Shelly as S-import Summoner.Question (doesExistProjectName)-import qualified System.Environment as SE+import Shelly qualified as S+import System.Environment qualified as SE import System.Process -import Util.Main (wrapMain)+import Morley.Util.Main (wrapMain) -import qualified FileGen+import FileGen qualified import Helper--data CmdLnArgs-  = New Text-  | Build-  | Run-  | Repl-  | Test+import Upgrade qualified -argParser :: Opt.Parser CmdLnArgs-argParser = subparser $-  newSubCmd <>-  buildSubCmd <>-  runSubCmd <>-  replSubCmd <>-  testSubCmd+argParser :: Opt.Parser (IO ())+argParser =+  subparser $+    newSubCmd <>+    buildSubCmd <>+    runSubCmd <>+    replSubCmd <>+    upgradeSubCmd <>+    testSubCmd    where-    mkCommandParser commandName parser desc =+    mkCommandParser commandName desc parser =       command commandName $       info (helper <*> parser) $       progDesc desc -    newSubCmd =-      mkCommandParser "new"-      (New <$> newArgOption)-      "Create a new project"--    buildSubCmd =-      mkCommandParser "build"-      (pure Build)-      "Build the current project"--    runSubCmd =-      mkCommandParser "run"-      (pure Run)-      "Run the current project"--    replSubCmd =-      mkCommandParser "repl"-      (pure Repl)-      "Access Indigo REPL"--    testSubCmd =-      mkCommandParser "test"-      (pure Test)-      "Run contract tests"--    newArgOption :: Opt.Parser Text-    newArgOption = Opt.strArgument (Opt.metavar "PROJECT NAME")--main :: IO ()-main = wrapMain $ do-  r <- isRunCommand-  case r of-    Just input -> do-      handleRunCommand input--    Nothing -> do-      cmdLnArgs <- execParser programInfo-      run cmdLnArgs--  where-    isRunCommand :: IO (Maybe [String])-    isRunCommand = do-      args <- SE.getArgs-      case args of-        "run":input -> pure $ Just input-        _ -> pure Nothing--    -- | Special case for handling @run@ command-    -- Since we want to pass the whole raw input to @ContractRegistry@-    -- it is easy to do it this way, because optparse seems to be not able to-    -- parse raw input.-    handleRunCommand :: [String] -> IO ()-    handleRunCommand input = do-      result <- Utf8.readFile "package.yaml"-      S.shelly . S.escaping False $ case getExecName (words result) of-        Just execName ->-          -- If we don't catch the exception here, 2 errors message will be print-          -- one by 'runStackWithArgs' and another by shelly itself.-          -- We still treat it as a fail command when the exception occurs by-          -- exit with error code 1.-          S.catch_sh @(S.ReThrownException SomeException)-            (runStackWithArgs (["run", execName, "--"] <> (toText <$> input)))-            (\_ -> S.quietExit 1)-        Nothing ->-          die "Could not find executable name in package.yaml"--    programInfo = info (helper <*> versionOption <*> argParser) $-      mconcat-      [ fullDesc-      , progDesc (toString indigoDesc)-      , header (toString indigoTitle)-      ]--    versionOption = infoOption ("indigo-" <> showVersion version)-      (long "version" <> help "Show version.")--    getExecName :: [Text] -> Maybe Text-    getExecName = \case-      "executables:":a:_ -> Just $ dropWhileEnd (==':') a-      _:xs -> getExecName xs-      _ -> Nothing+    projectName = Opt.strArgument (Opt.metavar "PROJECT_NAME") -    getLibName :: [Text] -> Maybe Text-    getLibName = \case-      "name:":a:_ -> Just a-      _ -> Nothing+    revisionArg = optional $ Opt.strOption $+         long "revision"+      <> Opt.metavar "REVISION"+      <> help "Git commit to pull from"+      <> Opt.internal -    run :: CmdLnArgs -> IO ()-    run = \case+    newArgs = (,) <$> projectName <*> revisionArg -      New projName ->+    newSubCmd =+      mkCommandParser "new"+      "Create a new project" $+      newArgs <&> \(projName, gitRev) -> do         case parsePackageName projName of           Right _ -> do             isNonUnique <- doesExistProjectName projName             if isNonUnique then               die "A project with this name already exists. Please choose another one."             else-              FileGen.run projName+              FileGen.run projName gitRev            Left err ->             die $ toString err -      Build -> do+    buildSubCmd =+      mkCommandParser "build"+      "Build the current project" $ pure $         S.shelly . S.escaping False $ runStackWithArgs ["build", "--fast"] -      -- | Placeholder command-      ---      -- @run@ will be handle by @handleRunCommand@-      -- This is defined only to show the description in @help@ command-      Run -> pure ()+    runSubCmd =+      command "run" $+      flip info (progDesc "Run the current project" <> Opt.noIntersperse <> Opt.forwardOptions) $+      many (Opt.strArgument $ Opt.metavar "ARGUMENTS") <&> \input -> do+        result <- Utf8.readFile "package.yaml"+        S.shelly . S.escaping False $ case getExecName (words result) of+          Just execName ->+            -- If we don't catch the exception here, 2 errors message will be print+            -- one by 'runStackWithArgs' and another by shelly itself.+            -- We still treat it as a fail command when the exception occurs by+            -- exit with error code 1.+            S.catch_sh @(S.ReThrownException SomeException)+              (runStackWithArgs (["run", execName, "--"] <> input))+              (\_ -> S.quietExit 1)+          Nothing ->+            die "Could not find executable name in package.yaml" -      Repl -> do+    replSubCmd =+      mkCommandParser "repl"+      "Access Indigo REPL" $ pure $ do         mbIndigoInDocker <- SE.lookupEnv "INDIGO_IN_DOCKER"         let dockerFlag = (maybe [] (const ["--allow-different-user"]) mbIndigoInDocker)         result <- Utf8.readFile "package.yaml"@@ -174,11 +105,41 @@          S.shelly $ S.liftIO $ callProcess "stack" $ dockerFlag <> ["repl", toString target] -      Test -> do+    testSubCmd =+      mkCommandParser "test"+      "Run contract tests" $ pure $         S.shelly . S.escaping False $ runStackWithArgs ["test", "--fast"] +    upgradeSubCmd =+      mkCommandParser "upgrade"+      "Upgrade indigo binary to the latest version" $+        Upgrade.run <$> revisionArg <*> Opt.switch (long "force" <> Opt.internal)+     runStackWithArgs :: [Text] -> S.Sh ()     runStackWithArgs args = do       mbIndigoInDocker <- liftIO $ SE.lookupEnv "INDIGO_IN_DOCKER"       let dockerFlag = (maybe [] (const ["--allow-different-user"]) mbIndigoInDocker)       S.shelly $ S.escaping False $ S.run_ "stack" $ dockerFlag <> args++    getExecName :: [Text] -> Maybe Text+    getExecName = \case+      "executables:":a:_ -> Just $ dropWhileEnd (==':') a+      _:xs -> getExecName xs+      _ -> Nothing++    getLibName :: [Text] -> Maybe Text+    getLibName = \case+      "name:":a:_ -> Just a+      _ -> Nothing++main :: IO ()+main = wrapMain $ do+  join $ execParser $ info (helper <*> versionOption <*> argParser) $+    mconcat+    [ fullDesc+    , progDesc (toString indigoDesc)+    , header (toString indigoTitle)+    ]+  where+    versionOption = infoOption ("indigo-" <> showVersion version)+      (long "version" <> help "Show version.")

@@ -0,0 +1,75 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Upgrade command implementation+module Upgrade+  ( run+  ) where++import Data.Text qualified as T+import Data.Version+import Network.HTTP.Req+  (GET(GET), HttpException, MonadHttp, NoReqBody(..), Scheme(Https), Url, bsResponse,+  defaultHttpConfig, queryParam, req, responseBody, runReq, (/:))+import Shelly qualified as S+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Text.ParserCombinators.ReadP (eof, readP_to_S)+import Universum.Lifted.File (writeFile)++import FileGen.Files (DependenceSnapshotVersion(..), indigoDependenceSnapshotYaml)+import Helper (repo)+import Paths_indigo (version)++run :: Maybe Text -> Bool -> IO ()+run mrevision bforce = do+  S.shelly $ S.escaping False $ S.withTmpDir $ \tempDir -> do+    let revision = fromMaybe "production" mrevision+    remoteVer <- runReq defaultHttpConfig $ do+      eresp <- try @_ @HttpException $ req GET+        (repo revision /: "package.yaml")+        NoReqBody+        bsResponse+        (queryParam @_ @Text "inline" (Just "false"))+      liftIO $ case eresp of+        Left err -> do+          putTextLn "Failed get new indigo version:"+          putStrLn $ displayException err+          exitFailure+        Right resp -> maybe (fail "Invalid package.yaml") (pure . fst) $+          responseBody resp+            & decodeUtf8+            & lines+            & find ("version:" `T.isPrefixOf`)+            >>= listToMaybe . drop 1 . words+            >>= listToMaybe . readP_to_S (parseVersion <* eof) . toString+    if remoteVer <= version && not bforce+    then putStrLn $ "Executable version " <> showVersion version <> " already up to date"+    else do+      runReq defaultHttpConfig $ getFile revision tempDir "indigo-snapshot.yaml"+      writeFile (tempDir </> "indigo-dependence-snapshot.yaml") $+        indigoDependenceSnapshotYaml $+          maybe (DSVPublishedVersion remoteVer) DSVGitCommitSha mrevision+      S.run_ "stack"+        ["install", "indigo", "--resolver"+        , toText $ tempDir </> "indigo-dependence-snapshot.yaml"]++getFile :: (MonadCatch m, MonadHttp m) => Text -> FilePath -> Text -> m ()+getFile revision configDir fn = do+  eresp <- try @_ @HttpException $ req GET+    (url revision fn)+    NoReqBody+    bsResponse+    (queryParam @_ @Text "inline" (Just "false"))+  case eresp of+    Left err -> do+      putStrLn $ "Failed to get " <> fn <> ":"+      putStrLn $ displayException err+    Right resp -> do+      let fp = configDir </> toString fn+          dep = decodeUtf8 $ responseBody resp+      liftIO $ createDirectoryIfMissing True configDir+      writeFile fp dep++url :: Text -> Text -> Url 'Https+url revision fn = repo revision /: "snapshots" /: fn

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           indigo-version:        0.5.0+version:        0.6.0 synopsis:       Convenient imperative eDSL over Lorentz. description:    Syntax and implementation of Indigo eDSL. category:       Language@@ -13,14 +13,13 @@ bug-reports:    https://gitlab.com/morley-framework/indigo/-/issues author:         Serokell, Tocqueville Group maintainer:     Serokell <hi@serokell.io>-copyright:      2019-2020 Tocqueville Group+copyright:      2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license:        MIT license-file:   LICENSE build-type:     Simple extra-source-files:     README.md     CHANGES.md-    snapshots/indigo-dependence-snapshot.yaml     snapshots/indigo-snapshot.yaml  source-repository head@@ -34,46 +33,95 @@       Indigo.Backend.Case       Indigo.Backend.Conditional       Indigo.Backend.Error+      Indigo.Backend.Expr.Compilation+      Indigo.Backend.Expr.Decompose       Indigo.Backend.Lambda+      Indigo.Backend.Lookup       Indigo.Backend.Prelude       Indigo.Backend.Scope       Indigo.Backend.Var+      Indigo.Common.Expr+      Indigo.Common.Expr.TH+      Indigo.Common.Field+      Indigo.Common.Object+      Indigo.Common.SIS+      Indigo.Common.State+      Indigo.Common.Var       Indigo.Compilation       Indigo.Compilation.Field       Indigo.Compilation.Hooks       Indigo.Compilation.Lambda       Indigo.Compilation.Params       Indigo.Compilation.Sequential+      Indigo.Compilation.Sequential.Types       Indigo.Frontend+      Indigo.Frontend.Expr+      Indigo.Frontend.Internal.Statement       Indigo.Frontend.Language       Indigo.Frontend.Program-      Indigo.Frontend.Statement-      Indigo.Internal-      Indigo.Internal.Expr-      Indigo.Internal.Expr.Compilation-      Indigo.Internal.Expr.Decompose-      Indigo.Internal.Expr.Symbolic-      Indigo.Internal.Expr.TH-      Indigo.Internal.Expr.Types-      Indigo.Internal.Field-      Indigo.Internal.Lookup-      Indigo.Internal.Object-      Indigo.Internal.SIS-      Indigo.Internal.State-      Indigo.Internal.Var       Indigo.Lib       Indigo.Lorentz       Indigo.Prelude       Indigo.Print-      Indigo.Rebinded+      Indigo.Rebound   other-modules:       Paths_indigo   autogen-modules:       Paths_indigo   hs-source-dirs:       src-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns NoApplicativeDo RebindableSyntax FunctionalDependencies-  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 -Wno-unused-do-bind -Wno-unticked-promoted-constructors+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumDecimals+      NumericUnderscores+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+      NoApplicativeDo+      RebindableSyntax+      FunctionalDependencies+  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 -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -Wno-unused-do-bind -Wno-unticked-promoted-constructors   build-depends:       base >=4.7 && <5     , casing@@ -98,27 +146,81 @@   other-modules:       FileGen       FileGen.Files+      FileGen.Tree       Helper+      Upgrade       Paths_indigo   autogen-modules:       Paths_indigo   hs-source-dirs:       app-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses 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+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumDecimals+      NumericUnderscores+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      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 -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages   build-depends:       base >=4.7 && <5+    , containers     , directory     , file-embed+    , filepath     , megaparsec >=7.0.0     , morley     , morley-prelude     , optparse-applicative     , process+    , req     , shelly     , string-interpolate-    , summoner     , text+    , time+    , tree-view+    , universum     , with-utf8   mixins:       base hiding (Prelude)@@ -144,8 +246,58 @@       Paths_indigo   hs-source-dirs:       test-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns NoApplicativeDo RebindableSyntax FunctionalDependencies-  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 -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumDecimals+      NumericUnderscores+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+      NoApplicativeDo+      RebindableSyntax+      FunctionalDependencies+  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 -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"   build-tool-depends:       tasty-discover:tasty-discover   build-depends:@@ -153,6 +305,7 @@     , base >=4.7 && <5     , cleveland     , containers+    , data-default     , fmt     , hedgehog     , hspec-expectations

@@ -1,11 +0,0 @@-# SPDX-FileCopyrightText: 2020 Tocqueville Group-# SPDX-License-Identifier: LicenseRef-MIT-TQ--name: indigo-dependence-snapshot--# See more extra-deps in 'indigo-snapshot.yaml'.-resolver: indigo-snapshot.yaml--# The 'packages' here act as 'extra-deps'.-packages:-  - indigo-0.5.0

@@ -1,5 +1,5 @@-# SPDX-FileCopyrightText: 2020 Tocqueville Group-# SPDX-License-Identifier: LicenseRef-MIT-TQ+# SPDX-FileCopyrightText: 2021 Oxhead Alpha+# SPDX-License-Identifier: LicenseRef-MIT-OA  name: indigo-snapshot @@ -8,30 +8,58 @@ # contain the latest snapshots and packages. To update them, you need # to have 'nix' and 'niv' installed and run the commands # 'niv update hackage.nix' and 'niv update stackage.nix'-resolver: lts-16.5+resolver: lts-19.3  # You might have to update hackage index used by CI when you update # packages in this list, see the comment at the top of the file # The 'packages' here act as 'extra-deps'. packages:-  - morley-1.11.0-  - morley-prelude-0.3.0-  - lorentz-0.9.0-  - tasty-hunit-compat-0.2-  - git:-      https://gitlab.com/morley-framework/morley.git # CI can't use SSH-    commit:-      fd1f796e970ed370285b4ca184a5d63c04483d19 # morley-1.11.0-    subdirs:-      - code/cleveland-      - code/morley-client+- morley-prelude-0.5.2+- morley-1.19.1+- lorentz-0.15.1+- morley-client-0.3.1+- cleveland-0.3.1 -  - base58-bytestring-0.1.0-  - hex-text-0.1.0.0-  - show-type-0.1.1-  - git: https://github.com/int-index/caps.git-    commit: c5d61837eb358989b581ed82b1e79158c4823b1b-  - named-0.3.0.1@sha256:69b9722301201f8ed8abc89c4595e22c746e944bf4cdfafa8b21b14d336b26d1,2233-  - vinyl-0.12.1@sha256:43456d4b3009646eee63953cbe539f1f4d0caf8bc3c25e841117e712836508f3,3790-  - cryptonite-0.27-  - uncaught-exception-0.1.0+- git: https://github.com/serokell/base-noprelude.git+  commit: c8b06c4c8a271fce0c2f41ab18e88d58e64bac52 # 4.15.1.0+- OddWord-1.0.2.0+- bitvec-1.0.3.0@sha256:f69ed0e463045cb497a7cf1bc808a2e84ea0ce286cf9507983bb6ed8b4bd3993,3977+- colourista-0.1.0.1@sha256:98353ee0e2f5d97d2148513f084c1cd37dfda03e48aa9dd7a017c9d9c0ba710e,3307+- named-0.3.0.1@sha256:418543272f0c844a77639b05276ee3906d5f305cd4cab46fafcb4f15b7f1e60d,2312+- show-type-0.1.1+- hsblst-0.0.1++- co-log-0.5.0.0+# Required by co-log+- chronos-1.1.5+- co-log-core-0.3.2.0+- typerep-map-0.5.0.0+# Required by chronos+- bytebuild-0.3.11.0+- byteslice-0.2.7.0+- bytesmith-0.3.9.0+# Required by byte*+- run-st-0.1.1.0+- zigzag-0.0.1.0+- contiguous-0.6.2.0++# Packages by Adjoint (somewhat unmaintained, hence they require constraints on their deps)+- galois-field-1.0.2+- elliptic-curve-0.3.0+- pairing-1.1.0+# Required by galois-field.+- protolude-0.2.4+- poly-0.4.0.0+# Required by pairing.+- groups-0.4.1.0+# For keyed BLAKE2b and NaCl secret box+- crypto-sodium-0.0.5.0+# Dependencies of crypto-sodium+- NaCl-0.0.5.0+- libsodium-1.0.18.2++flags:+  # Disable 'terminfo' haskell package, because it cannot be linked statically+  # https://github.com/purescript/purescript/issues/3696+  haskeline:+    terminfo: false

@@ -1,16 +1,21 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Indigo   ( module Exports   ) where +import Indigo.Common.Expr as Exports+import Indigo.Common.Field as Exports+import Indigo.Common.Object as Exports+import Indigo.Common.SIS as Exports+import Indigo.Common.State as Exports hiding ((>>))+import Indigo.Common.Var as Exports import Indigo.Compilation as Exports import Indigo.Frontend as Exports-import Indigo.Internal as Exports hiding ((>>)) import Indigo.Lib as Exports-import Indigo.Lorentz as Exports hiding (forcedCoerce)+import Indigo.Lorentz as Exports hiding+  (comment, commentAroundFun, commentAroundStmt, forcedCoerce, justComment) import Indigo.Prelude as Exports import Indigo.Print as Exports-import Indigo.Rebinded as Exports+import Indigo.Rebound as Exports

@@ -1,11 +1,16 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-redundant-constraints #-} --- | Strictly typed statements of Indigo language.-+-- | Indigo compiler back-end helpers.+--+-- For reference, "back-end" refers to the part of the compiler pipeline+-- that comes after the intermediate representation. In our case, intermediate+-- representation is defined in "Indigo.Frontend.Internal.Statement".+--+-- Essentially these definitions simplify target code generation.+-- This is not intended to be exported from "Indigo". module Indigo.Backend   ( module ReExports @@ -31,6 +36,7 @@   , transferTokens   , setDelegate   , createContract+  , emit    -- * Functions, Procedures and Scopes   , scope@@ -42,22 +48,31 @@ import Indigo.Backend.Case as ReExports import Indigo.Backend.Conditional as ReExports import Indigo.Backend.Error as ReExports+import Indigo.Backend.Expr.Compilation as ReExports+import Indigo.Backend.Expr.Decompose as ReExports import Indigo.Backend.Lambda as ReExports+import Indigo.Backend.Lookup as ReExports import Indigo.Backend.Scope as ReExports import Indigo.Backend.Var as ReExports  import Fmt (build, fmt, pretty, (+|), (|+))  import Indigo.Backend.Prelude-import Indigo.Internal hiding ((<>))-import Indigo.Lorentz-import qualified Lorentz.Doc as L-import qualified Lorentz.Entrypoints.Doc as L (finalizeParamCallingDoc)+import Indigo.Common.Expr (Expr)+import Indigo.Common.SIS+  (SomeGenCode(SomeGenCode), SomeIndigoState(SomeIndigoState), overSIS, runSIS)+import Indigo.Common.State+import Indigo.Common.Var (HasSideEffects, Var, pushNoRef, pushRef)+import Indigo.Lorentz hiding (comment)+import Lorentz.Doc qualified as L+import Lorentz.Entrypoints.Doc qualified as L (finalizeParamCallingDoc) import Lorentz.Entrypoints.Helpers (RequireSumType)-import qualified Lorentz.Instr as L-import qualified Lorentz.Run as L-import qualified Michelson.Typed as MT-import Util.Type (type (++))+import Lorentz.Ext qualified as L+import Lorentz.Instr qualified as L+import Lorentz.Run qualified as L+import Morley.Michelson.Typed qualified as MT+import Morley.Michelson.Untyped.Annotation (FieldAnn)+import Morley.Util.Type (type (++))  ---------------------------------------------------------------------------- -- Loop@@ -181,6 +196,8 @@   :: forall p inp mname.      ( NiceParameterFull p      , KnownValue (GetEntrypointArgCustom p mname)+     , IsoValue (ContractRef (GetEntrypointArgCustom p mname))+     , IsNotInView      )   => EntrypointRef mname   -> Var (ContractRef (GetEntrypointArgCustom p mname))@@ -191,10 +208,12 @@   assignTopVar var  contractCalling-  :: forall cp inp epRef epArg addr.+  :: forall cp vd inp epRef epArg addr.      ( HasEntrypointArg cp epRef epArg-     , ToTAddress cp addr+     , ToTAddress cp vd addr      , ToT addr ~ ToT Address+     , MT.HasNoOp (ToT epArg)+     , MT.HasNoNestedBigMaps (ToT epArg)      , KnownValue epArg      )   => epRef@@ -203,7 +222,7 @@   -- ^ Variable that will be assigned to the resulting 'ContractRef'   -> IndigoState inp (Maybe (ContractRef epArg) : inp) contractCalling epRef addr var = stmtHookState (pretty var <> " := contractCalling " <> pretty addr) $ do-  unaryOp addr (L.contractCalling @cp epRef)+  unaryOp addr (L.contractCalling @cp @_ @_ @_ @vd epRef)   assignTopVar var  ----------------------------------------------------------------------------@@ -211,19 +230,21 @@ ----------------------------------------------------------------------------  transferTokens-  :: (NiceParameter p, HasSideEffects)+  :: (NiceParameter p, HasSideEffects, IsNotInView)   => Expr p -> Expr Mutez -> Expr (ContractRef p)   -> IndigoState inp inp transferTokens ep em ec = withStackVars $ \s ->   ternaryOpFlat ep em ec (L.transferTokens # varActionOperation s) -setDelegate :: HasSideEffects => Expr (Maybe KeyHash) -> IndigoState inp inp+setDelegate :: (HasSideEffects, IsNotInView) => Expr (Maybe KeyHash) -> IndigoState inp inp setDelegate e = withStackVars $ \s ->   unaryOpFlat e (L.setDelegate # varActionOperation s)  createContract-  :: (HasSideEffects, NiceStorage s, NiceParameterFull p)-  => L.Contract p s+  :: ( HasSideEffects, NiceStorage s, NiceParameterFull p+     , NiceViewsDescriptor vd, Typeable vd, IsNotInView+     )+  => L.Contract p s vd   -> Expr (Maybe KeyHash)   -> Expr Mutez   -> Expr s@@ -233,8 +254,14 @@ createContract lCtr ek em es var = stmtHookState   (fmt $ build var +| " := createContract (key_hash = " +| ek |+ ", mutez = " +| em |+ ", storage = " <> build es) $ do     withStackVars $ \s ->-      ternaryOp ek em es $ L.createContract lCtr # varActionOperation (pushNoRef s)+      ternaryOp ek em es $ L.createContract lCtr # varActionOperation (pushNoRef s) # checkedCoerce_     assignTopVar var++emit+  :: (HasSideEffects, NicePackedValue a, HasAnnotation a)+  => FieldAnn -> Expr a -> IndigoState inp inp+emit tag ex = withStackVars $ \s ->+  unaryOpFlat ex $ L.emit tag # varActionOperation s  ---------------------------------------------------------------------------- -- Functions, Procedures and Scopes

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -18,18 +17,22 @@  import Data.Vinyl.Core (RMap(..)) import Fmt (pretty)-import Util.Type (type (++))-import Util.TypeLits (AppendSymbol) +import Indigo.Backend.Expr.Compilation (compileExpr) import Indigo.Backend.Prelude import Indigo.Backend.Scope-import Indigo.Internal hiding ((<>))+import Indigo.Common.Expr (Expr)+import Indigo.Common.SIS (SomeGenCode(SomeGenCode), SomeIndigoState(SomeIndigoState))+import Indigo.Common.State+import Indigo.Common.Var (Var) import Indigo.Lorentz-import qualified Lorentz.ADT as L-import qualified Lorentz.Entrypoints.Doc as L-import qualified Lorentz.Instr as L-import Michelson.Typed.Haskell.Instr.Sum+import Lorentz.ADT qualified as L+import Lorentz.Entrypoints.Doc qualified as L+import Lorentz.Instr qualified as L+import Morley.Michelson.Typed.Haskell.Instr.Sum   (CaseClauseParam(..), CaseClauses, CtorField(..), InstrCaseC)+import Morley.Util.Type (type (++))+import Morley.Util.TypeLits (AppendSymbol)  -- | This type is analogous to the 'CaseClauseL' type but instead of wrapping a Lorentz -- instruction, this wraps an Indigo value with the same input/output types.

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -14,16 +13,20 @@   , IfConstraint   ) where -import qualified Data.Kind as Kind-import qualified GHC.TypeLits as Lit-import Util.Type (type (++))+import Data.Kind qualified as Kind+import GHC.TypeLits qualified as Lit+import Morley.Util.Type (type (++)) +import Indigo.Backend.Expr.Compilation (compileExpr) import Indigo.Backend.Prelude import Indigo.Backend.Scope-import Indigo.Internal hiding ((<>))+import Indigo.Common.Expr (Expr)+import Indigo.Common.SIS (SomeIndigoState, runSIS)+import Indigo.Common.State+import Indigo.Common.Var (Var) import Indigo.Lorentz-import qualified Lorentz.Instr as L-import qualified Lorentz.Macro as L+import Lorentz.Instr qualified as L+import Lorentz.Macro qualified as L  type family CompareBranchesResults (a :: Kind.Type) (b :: Kind.Type) :: Constraint where   CompareBranchesResults x x = ()

@@ -8,22 +8,24 @@  module Indigo.Backend.Error   ( failWith+  , never   , failUsing_   , failCustom   , failCustom_+  , failCustomNoArg   , failUnexpected_   ) where  import Fmt (Buildable, pretty) +import Indigo.Backend.Expr.Compilation import Indigo.Backend.Prelude-import Indigo.Internal.Expr.Compilation-import Indigo.Internal.Expr.Types-import Indigo.Internal.State-import Indigo.Internal.Var+import Indigo.Common.Expr+import Indigo.Common.State+import Indigo.Common.Var import Indigo.Lorentz-import qualified Lorentz.Errors as L-import qualified Lorentz.Instr as L+import Lorentz.Errors qualified as L+import Lorentz.Instr qualified as L  -- | Generic generator of failing 'IndigoState' from failing Lorentz instructions. failIndigoState :: inp :-> out -> IndigoState inp out@@ -32,33 +34,45 @@     gcStack = FailureStack     gcClear = L.unit # L.failWith -failWith :: KnownValue a => Expr a -> IndigoState s t+failWith :: NiceConstant a => Expr a -> IndigoState s t failWith exa = stmtHookState ("failWith (" <> pretty exa <> ")") $   exprHookState (pretty exa) (compileExpr exa) >>   failIndigoState L.failWith +never :: Expr Never -> IndigoState s t+never exa = stmtHookState ("never (" <> pretty exa <> ")") $+  exprHookState (pretty exa) (compileExpr exa) >>+  failIndigoState L.never+ failUsing_ :: (IsError x, Buildable x) => x -> IndigoState s t failUsing_ x = stmtHookState ("failUsing_ (" <> pretty x <> ")") $ failIndigoState (failUsing x)  failCustom   :: forall tag err s t.-     ( err ~ ErrorArg tag+     ( MustHaveErrorArg tag (MText, err)      , CustomErrorHasDoc tag      , NiceConstant err      )   => Label tag -> Expr err -> IndigoState s t-failCustom l errEx = stmtHookState ("failCustom (" <> pretty errEx <> ")") $-  withDict (niceConstantEvi @err) $ do-    exprHookState (pretty errEx) (compileExpr errEx)-    failIndigoState $ L.failCustom l+failCustom l errEx = stmtHookState ("failCustom (" <> pretty errEx <> ")") do+  exprHookState (pretty errEx) (compileExpr errEx)+  failIndigoState $ L.failCustom l  failCustom_-  :: forall tag s t notVoidErrorMsg.-     ( RequireNoArgError tag notVoidErrorMsg+  :: forall tag s t.+     ( MustHaveErrorArg tag (MText, ())      , CustomErrorHasDoc tag      )   => Label tag -> IndigoState s t failCustom_ = stmtHookState "failCustom_" . failIndigoState . L.failCustom_++failCustomNoArg+  :: forall tag s t.+     ( MustHaveErrorArg tag MText+     , CustomErrorHasDoc tag+     )+  => Label tag -> IndigoState s t+failCustomNoArg = stmtHookState "failCustomNoArg" . failIndigoState . L.failCustomNoArg  failUnexpected_ :: MText -> IndigoState s t failUnexpected_ msg =

@@ -0,0 +1,360 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | 'Expr' compilation++module Indigo.Backend.Expr.Compilation+  ( compileExpr++  , ObjManipulationRes (..)+  , runObjectManipulation+  , namedToExpr++  , nullaryOp+  , unaryOp+  , binaryOp+  , ternaryOp++  , nullaryOpFlat+  , unaryOpFlat+  , binaryOpFlat+  , ternaryOpFlat+  ) where++import Data.Vinyl.Core (RMap(..))++import Lorentz.ADT qualified as L+import Lorentz.Instr qualified as L+import Lorentz.Macro qualified as L+import Lorentz.StoreClass qualified as L+import Morley.Michelson.Typed.Haskell.Instr.Product (GetFieldType)++import Indigo.Backend.Lookup (varActionGet)+import Indigo.Backend.Prelude+import Indigo.Common.Expr+import Indigo.Common.Field+import Indigo.Common.Object+  (IndigoObjectF(..), NamedFieldObj(..), castFieldConstructors, namedToTypedRec, typedToNamedRec)+import Indigo.Common.State+  (DecomposedObjects, GenCode(..), IndigoState(..), MetaData(..), replStkMd, usingIndigoState,+  withObject, withObjectState)+import Indigo.Common.Var (Var(..), pushNoRef)+import Indigo.Lorentz++compileExpr :: forall a inp . Expr a -> IndigoState inp (a : inp)+compileExpr (C a) = IndigoState $ \md -> GenCode (pushNoRef $ mdStack md) (L.push a) L.drop+compileExpr (V v) = withObjectState v $ compileObjectF namedToExpr+compileExpr (Update m key val) = ternaryOp key val m L.update+compileExpr (Add e1 e2) = binaryOp e1 e2 L.add+compileExpr (Sub e1 e2) = binaryOp e1 e2 L.sub+compileExpr (Mul e1 e2) = binaryOp e1 e2 L.mul+compileExpr (Div (e1 :: Expr e1) (e2 :: Expr e2) (_ :: Proxy reminder)) =+  binaryOp e1 e2 (L.ediv @_ @_ @(Maybe (a, reminder)) # L.ifSome L.car (failUsing [mt|division by zero|]))+compileExpr (Mod (e1 :: Expr e1) (e2 :: Expr e2) (_ :: Proxy ratio)) =+  binaryOp e1 e2 (L.ediv @_ @_ @(Maybe (ratio, a)) # L.ifSome L.cdr (failUsing [mt|division by zero|]))+compileExpr (Abs e) = unaryOp e L.abs+compileExpr (Neg e) = unaryOp e L.neg++compileExpr (Lsl e1 e2) = binaryOp e1 e2 L.lsl+compileExpr (Lsr e1 e2) = binaryOp e1 e2 L.lsr++compileExpr (Eq' e1 e2) = binaryOp e1 e2 L.eq+compileExpr (Neq e1 e2) = binaryOp e1 e2 L.neq+compileExpr (Lt e1 e2) = binaryOp e1 e2 L.lt+compileExpr (Le e1 e2) = binaryOp e1 e2 L.le+compileExpr (Gt e1 e2) = binaryOp e1 e2 L.gt+compileExpr (Ge e1 e2) = binaryOp e1 e2 L.ge+compileExpr (IsNat e) = unaryOp e L.isNat+compileExpr (Int' e) = unaryOp e L.int+compileExpr (Coerce e) = unaryOp e checkedCoerce_+compileExpr (ForcedCoerce e) = unaryOp e forcedCoerce_+compileExpr (And e1 e2) = binaryOp e1 e2 L.and+compileExpr (Or e1 e2) = binaryOp e1 e2 L.or+compileExpr (Xor e1 e2) = binaryOp e1 e2 L.xor+compileExpr (Not e) = unaryOp e L.not++compileExpr (Fst e) = unaryOp e L.car+compileExpr (Snd e) = unaryOp e L.cdr+compileExpr (Pair e1 e2) = binaryOp e1 e2 L.pair++compileExpr (Some e) = unaryOp e L.some+compileExpr None = nullaryOp L.none+compileExpr (Right' e) = unaryOp e L.right+compileExpr (Left' e) = unaryOp e L.left+compileExpr (Pack e) = unaryOp e L.pack+compileExpr (Unpack e) = unaryOp e L.unpack+compileExpr (PackRaw e) = unaryOp e L.packRaw+compileExpr (UnpackRaw e) = unaryOp e L.unpackRaw+compileExpr Nil = nullaryOp L.nil+compileExpr (Cons e1 e2) = binaryOp e1 e2 L.cons+compileExpr (Contract (Proxy :: Proxy vd) e) = unaryOp e (L.contract @_ @vd)+compileExpr Self = nullaryOp L.self+compileExpr SelfAddress = nullaryOp L.selfAddress+compileExpr (ContractAddress ec) = unaryOp ec L.address+compileExpr (ContractCallingUnsafe epName addr) = unaryOp addr (L.unsafeContractCalling epName)+compileExpr (RunFutureContract con) = unaryOp con L.runFutureContract+compileExpr (ConvertEpAddressToContract epAddr) = unaryOp epAddr L.epAddressToContract+compileExpr (MakeView e1 e2) = binaryOp e1 e2 (L.pair # L.wrapView_)+compileExpr (MakeVoid e1 e2) = binaryOp e1 e2 (L.pair # L.wrapVoid)++compileExpr (Mem k c) = binaryOp k c L.mem+compileExpr (Size s) = unaryOp s L.size++compileExpr (StInsertNew l err k v store) =+  ternaryOp k v store $ L.stInsertNew (fieldNameFromLabel l) (failUsing err)+compileExpr (StInsert l k v store) =+  ternaryOp k v store $ L.stInsert (fieldNameFromLabel l)+compileExpr (StGet l ekey estore) =+  binaryOp ekey estore (L.stGet (fieldNameFromLabel l))+compileExpr (StMem l ekey estore) =+  binaryOp ekey estore (L.stMem (fieldNameFromLabel l))+compileExpr (StUpdate l ekey evalue estore) =+  ternaryOp ekey evalue estore (L.stUpdate (fieldNameFromLabel l))+compileExpr (StDelete l ekey estore) =+  binaryOp ekey estore (L.stDelete (fieldNameFromLabel l))++compileExpr (Wrap l exFld) = unaryOp exFld $ L.wrapOne l+compileExpr (Unwrap l exDt) = unaryOp exDt $ L.unsafeUnwrap_ l++compileExpr (ObjMan fldAcc) = compileObjectManipulation fldAcc+compileExpr (Construct _ fields) = IndigoState $ \md ->+  let cd = L.construct $ rmap (\e -> fieldCtor $ gcCode $ runIndigoState (compileExpr e) md) fields in+  GenCode (pushNoRef $ mdStack md) cd L.drop+compileExpr (ConstructWithoutNamed _ fields) = IndigoState $ \md ->+  let fieldCtrs =+          castFieldConstructors @a $+            rmap (fieldCtor . gcCode . usingIndigoState md . compileExpr) fields+  in GenCode (pushNoRef $ mdStack md) (L.construct @a fieldCtrs) L.drop+compileExpr (Name l e) = unaryOp e (toNamed l)+compileExpr (UnName l e) = unaryOp e (fromNamed l)++compileExpr (Slice ex1 ex2 ex3) = ternaryOp ex1 ex2 ex3 L.slice+compileExpr (Cast ex) = unaryOp ex L.cast+compileExpr (Concat ex1 ex2) = binaryOp ex1 ex2 L.concat+compileExpr (Concat' ex) = unaryOp ex L.concat'++compileExpr (ImplicitAccount kh) = unaryOp kh L.implicitAccount+compileExpr Now = nullaryOp L.now+compileExpr Sender = nullaryOp L.sender+compileExpr Amount = nullaryOp L.amount+compileExpr (CheckSignature pk sig bs) = ternaryOp pk sig bs L.checkSignature+compileExpr (Sha256 c) = unaryOp c L.sha256+compileExpr (Sha512 c) = unaryOp c L.sha512+compileExpr (Blake2b c) = unaryOp c L.blake2B+compileExpr (Sha3 c) = unaryOp c L.sha3+compileExpr (Keccak c) = unaryOp c L.keccak+compileExpr (HashKey hk) = unaryOp hk L.hashKey+compileExpr ChainId = nullaryOp L.chainId+compileExpr Balance = nullaryOp L.balance+compileExpr Level = nullaryOp L.level+compileExpr (VotingPower ex) = unaryOp ex L.votingPower+compileExpr TotalVotingPower = nullaryOp L.totalVotingPower++compileExpr EmptySet = nullaryOp L.emptySet++compileExpr (Get k m) = binaryOp k m L.get+compileExpr EmptyMap = nullaryOp L.emptyMap+compileExpr EmptyBigMap = nullaryOp L.emptyBigMap++compileExpr (Exec inp lambda) = binaryOp inp lambda L.exec+compileExpr (NonZero e) = unaryOp e L.nonZero++--------------------------------------------+-- Object manipulation: set, get fields+--------------------------------------------++-- | Compile 'ObjectManipulation' datatype to a cell on the stack.+-- This function leverages 'ObjManipulationRes' to put off actual field compilation.+compileObjectManipulation :: ObjectManipulation a -> IndigoState inp (a : inp)+compileObjectManipulation fa = IndigoState $ \md -> case runObjectManipulation (mdObjects md) fa of+  StillObject composite -> usingIndigoState md $ compileObjectF unNamedFieldExpr composite+  OnStack computation   -> usingIndigoState md computation++namedToExpr :: NamedFieldObj x name -> Expr (GetFieldType x name)+namedToExpr (NamedFieldObj flObj) = objToExpr namedToExpr flObj++-- | Convert arbitrary 'IndigoObjectF' into 'Expr'+-- with respect to given converter for fields.+objToExpr+  :: forall a f .+     (forall name . f name -> Expr (GetFieldType a name))+  -> IndigoObjectF f a+  -> Expr a+objToExpr _ (Cell refId) = V (Var @a refId)+objToExpr convExpr (Decomposed fields) =+  ConstructWithoutNamed (Proxy @a) (namedToTypedRec @a convExpr fields)++-- | Compile 'IndigoObjectF' to a stack cell,+-- with respect to given function that compiles inner fields.+compileObjectF+  :: forall a inp f .+     (forall name . f name -> Expr (GetFieldType a name))+  -> IndigoObjectF f a+  -> IndigoState inp (a : inp)+compileObjectF _ (Cell ref) = IndigoState $ \(mdStack -> s) ->+  GenCode (pushNoRef s) (varActionGet @a ref s) L.drop+compileObjectF conv obj = compileExpr $ objToExpr conv obj++-- | 'ObjManipulationRes' represents a postponed compilation of+-- 'ObjectManipulation' datatype. When 'ObjectManipulation' is being compiled+-- we are trying to put off the generation of code for work with an object+-- because we can just go to a deeper field without its "materialization"+-- onto stack.+data ObjManipulationRes inp a where+  StillObject :: ObjectExpr a -> ObjManipulationRes inp a+  OnStack :: IndigoState inp (a : inp) -> ObjManipulationRes inp a++-- | This function might look cumbersome+-- but basically it either goes deeper to an inner field or generates Lorentz code.+runObjectManipulation :: DecomposedObjects -> ObjectManipulation x -> ObjManipulationRes inp x+runObjectManipulation objs (Object e) = exprToManRes objs e++runObjectManipulation objs (ToField (v :: ObjectManipulation dt) (targetLb :: Label fname)) =+  case runObjectManipulation objs v of+    -- In case of decomposed fields, we just go deeper.+    StillObject (Decomposed fields) ->+      case fieldLens @dt @fname of+        -- If we access direct field, we just fetch it from fields+        TargetField lb _ -> exprToManRes objs $ unNamedFieldExpr (fetchField @dt lb fields)+        -- If we access deeper field, we fetch direct field and goes to the deeper field+        DeeperField lb _ ->+          let fe = unNamedFieldExpr $ fetchField @dt lb fields in+          runObjectManipulation objs (ToField (Object fe) targetLb)+    -- If stored object as cell on the stack, we get its field+    -- using 'sopToField', and since this moment 'ObjManipulationRes becomes+    -- a computation, not object anymore.+    StillObject (Cell refId) ->+      OnStack $ unaryOp (V $ Var refId) (sopToField @dt (flSFO fieldLens) (fieldNameFromLabel targetLb))+    -- If we already got into computation, we use 'sopToField' to fetch field.+    OnStack compLHS -> OnStack $ IndigoState $ \mdI ->+      let cd = gcCode $ usingIndigoState mdI compLHS in+      GenCode (pushNoRef $ mdStack mdI) (cd # sopToField (flSFO fieldLens) (fieldNameFromLabel targetLb)) L.drop++runObjectManipulation objs (SetField (ev :: ObjectManipulation dt) (targetLb :: Label fname) ef) =+  case runObjectManipulation objs ev of+    StillObject lhsObj@(Decomposed fields) ->+      case fieldLens @dt @fname of+        -- If we set direct field, we just reassign its value with new one.+        TargetField lb _ ->+          StillObject $ Decomposed $ assignField @dt lb (NamedFieldExpr ef) fields+        -- If we set deeper field, we need to call recursively+        -- from a direct field, and set a target field of direct field.+        -- Getting a new value of direct field, we set the direct field to this value.+        DeeperField (lb :: Label interm) _ ->+          let fe = unNamedFieldExpr (fetchField @dt lb fields) in+          -- Computing new value of direct field+          case runObjectManipulation objs (SetField (Object fe) targetLb ef) of+            -- If it's still an object, we just reassign direct field with it.+            StillObject updField -> StillObject $ Decomposed $+              assignField @dt lb (NamedFieldExpr $ objToExpr unNamedFieldExpr updField) fields+            -- Otherwise, we use power of 'L.setField' to set a new value.+            OnStack rhs ->+              setFieldOnStack (compileObjectF unNamedFieldExpr lhsObj) rhs (L.setField @dt @interm lb)+    -- If stored object is Cell on stack, we set its field+    -- using 'sopSetField', and since this moment 'ObjManipulationRes' becomes+    -- a computation, not object anymore.+    StillObject (Cell refId) ->+      OnStack $ binaryOp ef (V $ Var refId) $ sopSetField (flSFO fieldLens) (fieldNameFromLabel targetLb)+    -- If we already got into computation, we use 'sopSetField' to set a field.+    OnStack compLHS ->+      setFieldOnStack compLHS (compileExpr ef) (sopSetField (flSFO $ fieldLens @dt) (fieldNameFromLabel targetLb))+  where+    setFieldOnStack+      :: IndigoState inp (dt : inp)+      -> IndigoState (dt : inp) (fld : dt : inp)+      -> fld : dt : inp :-> dt : inp+      -> ObjManipulationRes inp dt+    setFieldOnStack lhs rhs setOp = OnStack $ IndigoState $ \mdI ->+      let GenCode st1 cdObj _cl1 = runIndigoState lhs mdI in+      let GenCode _st2 cdFld _cl2 = runIndigoState rhs (replStkMd mdI st1) in+      GenCode (pushNoRef $ mdStack mdI) (cdObj # cdFld # setOp) L.drop++-- | Convert an expression to 'ObjManipulationRes'.+-- The function pattern matches on some specific cases+-- of expression those compilation into a stack cell may be postponed.+-- They include 'Decomposed' variables and 'ConstructWithoutNamed' expressions.+--+-- This function can't be called for 'ObjMan' constructor, but we+-- take care of it just in case.+exprToManRes :: forall x inp . DecomposedObjects -> Expr x -> ObjManipulationRes inp x+exprToManRes objs (ObjMan objMan) = runObjectManipulation objs objMan+exprToManRes _ (ConstructWithoutNamed _ fields) =+  StillObject $ Decomposed $ typedToNamedRec @x NamedFieldExpr fields+exprToManRes objs (V var) = withObject objs var $ \case+  Cell refId ->+    StillObject $ Cell refId+  Decomposed fields ->+    StillObject $ Decomposed $ rmap (NamedFieldExpr . namedToExpr) fields+exprToManRes _ ex = OnStack $ compileExpr ex++---------------------------------------------------+-- Convenient helpers for operators compilation+---------------------------------------------------++ternaryOp+  :: KnownValue res+  => Expr n+  -> Expr m+  -> Expr l+  -> n : m : l : inp :-> res : inp+  -> IndigoState inp (res : inp)+ternaryOp e1 e2 e3 opCode = IndigoState $ \md ->+  let GenCode st3 cd3 _cl3  = runIndigoState (compileExpr e3) md in+  let GenCode st2 cd2 _cl2  = runIndigoState (compileExpr e2) (replStkMd md st3) in+  let GenCode _st1 cd1 _cl1 = runIndigoState (compileExpr e1) (replStkMd md st2) in+  GenCode (pushNoRef $ mdStack md) (cd3 # cd2 # cd1 # opCode) L.drop++binaryOp+  :: KnownValue res+  => Expr n -> Expr m+  -> n : m : inp :-> res : inp+  -> IndigoState inp (res : inp)+binaryOp e1 e2 opCode = IndigoState $ \md ->+  let GenCode st2 cd2 _cl2  = runIndigoState (compileExpr e2) md in+  let GenCode _st1 cd1 _cl1 = runIndigoState (compileExpr e1) (replStkMd md st2) in+  GenCode (pushNoRef $ mdStack md) (cd2 # cd1 # opCode) L.drop++unaryOp+  :: KnownValue res+  => Expr n+  -> n : inp :-> res : inp+  -> IndigoState inp (res : inp)+unaryOp e opCode = IndigoState $ \md ->+  let cd = gcCode $ runIndigoState (compileExpr e) md in+  GenCode (pushNoRef $ mdStack md) (cd # opCode) L.drop++nullaryOp :: KnownValue res => inp :-> res ': inp -> IndigoState inp (res ': inp)+nullaryOp lorentzInstr = IndigoState $ \md ->+  GenCode (pushNoRef $ mdStack md) lorentzInstr L.drop++ternaryOpFlat+  :: Expr n+  -> Expr m+  -> Expr l+  -> n : m : l : inp :-> inp+  -> IndigoState inp inp+ternaryOpFlat e1 e2 e3 opCode = IndigoState $ \md ->+  let GenCode st3 cd3 _cl3  = runIndigoState (compileExpr e3) md in+  let GenCode st2 cd2 _cl2  = runIndigoState (compileExpr e2) (replStkMd md st3) in+  let GenCode _st1 cd1 _cl1 = runIndigoState (compileExpr e1) (replStkMd md st2) in+  GenCode (mdStack md) (cd3 # cd2 # cd1 # opCode) L.nop++binaryOpFlat+  :: Expr n -> Expr m+  -> n : m : inp :-> inp+  -> IndigoState inp inp+binaryOpFlat e1 e2 opCode = IndigoState $ \md ->+  let GenCode st2 cd2 _cl2  = runIndigoState (compileExpr e2) md in+  let GenCode _st1 cd1 _cl1 = runIndigoState (compileExpr e1) (replStkMd md st2) in+  GenCode (mdStack md) (cd2 # cd1 # opCode) L.nop++unaryOpFlat+  :: Expr n+  -> n : inp :-> inp+  -> IndigoState inp inp+unaryOpFlat e opCode = IndigoState $ \md ->+  let cd = gcCode $ runIndigoState (compileExpr e) md in+  GenCode (mdStack md) (cd # opCode) L.nop++nullaryOpFlat :: inp :-> inp -> IndigoState inp inp+nullaryOpFlat lorentzInstr = IndigoState $ \md -> GenCode (mdStack md) lorentzInstr L.nop

@@ -0,0 +1,143 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Decompose a complex value into its fields+-- to be used in 'setVar'.+-- Also functionality to generate code to deconstruct storage+-- into primitive fields the storage consists of+-- and to construct it back.+module Indigo.Backend.Expr.Decompose+  ( decomposeExpr+  , deepDecomposeCompose+  , ExprDecomposition (..)+  , IsObject+  ) where++import Prelude++import Data.Constraint (Dict(..))+import Data.Vinyl.TypeLevel hiding (type (++))++import Indigo.Backend.Expr.Compilation+import Indigo.Backend.Lookup+import Indigo.Common.Expr+import Indigo.Common.Object+import Indigo.Common.SIS+import Indigo.Common.State+import Indigo.Common.Var+import Indigo.Lorentz+import Lorentz.ADT qualified as L+import Lorentz.Instr qualified as L+import Morley.Michelson.Typed.Haskell.Instr.Product (GetFieldType)+import Morley.Util.Type++-----------------------------------------+-- Object decomposition+-----------------------------------------++-- | Alike 'SomeIndigoState' datatype but without objects argument+type SIS' stk a = RefId -> StackVars stk -> (a, RefId, SomeGenCode stk)++-- | For given element on stack, generate code which+-- decomposes it to list of its deep non-decomposable fields.+-- Clean up code of 'SomeIndigoState' composes the value back.+deepDecomposeCompose+  :: forall a inp . IsObject a+  => SIS' (a : inp) (Object a)+deepDecomposeCompose+  | Just Dict <- complexObjectDict @a = \refId st ->+      let decomposedSt = fst (noRefGenCode @(FieldTypes a) $ popNoRef st)+      in withInstrDeconstructC @a @inp $+        withStack refId decomposedSt (decomposeComposeFields @(FieldTypes a)) $+          \(result, newRefId, gc) ->+            ( Decomposed (typedToNamedRec @a typedToNamedFieldObj result)+            , newRefId+            , SomeGenCode $ GenCode+              { gcStack = gcStack gc+              , gcCode = L.deconstruct @a @(FieldTypes a) # gcCode gc+              , gcClear = gcClear gc # L.constructStack @a  @(FieldTypes a)+              }+            )+  | otherwise =+      \refId stk -> (Cell refId, refId + 1, SomeGenCode $+                      usingIndigoState (MetaData stk mempty emptyGenCodeHooks) (assignTopVar $ Var refId) )+  where+    decomposeComposeFields+      :: forall flds . (KnownList flds, AllConstrained IsObject flds)+      => SIS' (flds ++ inp) (Rec TypedFieldObj flds)+    decomposeComposeFields = case klist @flds of+      KNil -> \refId stk -> (RNil, refId, SomeGenCode $ GenCode stk L.nop L.nop)+      KCons (_ :: Proxy r) (_ :: Proxy rest) -> \refId st ->+        withStack refId (popNoRef st) (decomposeComposeFields @rest) $ \(resultRest, refId', restGc) ->+          withStack refId' (pushNoRef $ gcStack restGc) (deepDecomposeCompose @r) $ \(resultCur, newRefId, curGc) ->+            ( TypedFieldObj resultCur :& resultRest+            , newRefId+            , SomeGenCode $ GenCode+              { gcStack = gcStack curGc+              , gcCode = L.dip (gcCode restGc) # gcCode curGc+              , gcClear = gcClear curGc # L.dip (gcClear restGc)+              }+            )++withStack+  :: RefId+  -> StackVars inp+  -> SIS' inp a+  -> (forall out . (a, RefId, GenCode inp out) -> r)+  -> r+withStack refId stk sis f = case sis refId stk of+  (res, newRefId, SomeGenCode genCode) -> f (res, newRefId, genCode)++-----------------------------------------+-- Expr decomposition+-----------------------------------------++-- | Datatype representing decomposition of 'Expr'.+data ExprDecomposition inp a where+  ExprFields :: Rec Expr (FieldTypes a) -> ExprDecomposition inp a+  Deconstructed :: IndigoState inp (FieldTypes a ++ inp) -> ExprDecomposition inp a++-- | Decompose (shallowly) an expression to list of its direct fields.+decomposeExpr :: ComplexObjectC a => DecomposedObjects -> Expr a -> ExprDecomposition inp a+decomposeExpr _ (ConstructWithoutNamed _ fields) = ExprFields fields+decomposeExpr objs (V v) = withObject objs v $ decomposeObjectF namedToExpr+decomposeExpr objs (ObjMan objMan) = case runObjectManipulation objs objMan of+  StillObject obj -> decomposeObjectF unNamedFieldExpr obj+  OnStack comp -> deconstructOnStack comp+decomposeExpr _ ex = deconstructOnStack $ compileExpr ex++-- | Decompose any 'IndigoObjectF' with regards to decomposer for field.+decomposeObjectF+  :: forall a inp f . ComplexObjectC a+  => (forall name . f name -> Expr (GetFieldType a name))+  -> IndigoObjectF f a+  -> ExprDecomposition inp a+decomposeObjectF _ (Cell refId) =+  deconstructOnStack $+    IndigoState $ \md -> GenCode (pushNoRef $ mdStack md) (varActionGet @a refId $ mdStack md) L.drop+decomposeObjectF unF (Decomposed fields) =+  ExprFields $ namedToTypedRec @a unF fields++-- | Deconstruct top element of the stack and return it+-- wrapped into 'Deconstructed' constructor.+deconstructOnStack+  :: forall a inp . ComplexObjectC a+  => IndigoState inp (a : inp)+  -> ExprDecomposition inp a+deconstructOnStack fetchFld =+  Deconstructed $ IndigoState $ \md ->+    let (newSt, clean) = noRefGenCode @(FieldTypes a) (mdStack md) in+    withInstrDeconstructC @a @inp $+      GenCode newSt (gcCode (runIndigoState fetchFld md) # L.deconstruct @a @(FieldTypes a)) clean++-----------------------------------------+-- Helpers+-----------------------------------------++-- | Push the passed stack cells without references to them.+noRefGenCode+  :: forall rs inp . (KnownList rs, AllConstrained KnownValue rs)+  => StackVars inp -> (StackVars (rs ++ inp), (rs ++ inp) :-> inp)+noRefGenCode md = case klist @rs of+  KNil -> (md, L.nop)+  KCons Proxy (_ :: Proxy rest) -> bimap pushNoRef (L.drop #) (noRefGenCode @rest md)

@@ -1,7 +1,8 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# LANGUAGE NoMonomorphismRestriction #-}+ -- | This module implements the ability to put -- Indigo computations on the stack as a lambda and execute them. module Indigo.Backend.Lambda@@ -24,17 +25,24 @@   , Lambda1Generic   ) where -import Data.Constraint (Dict(..))+import Data.Constraint ((\\)) import Fmt (fmt, pretty, (+|), (|+)) +import Indigo.Backend.Expr.Compilation (compileExpr)+import Indigo.Backend.Lookup (varActionGet, varActionSet) import Indigo.Backend.Prelude import Indigo.Backend.Scope import Indigo.Backend.Var-import Indigo.Internal hiding ((+), (<>))+import Indigo.Common.Expr (Expr(V))+import Indigo.Common.Object (IsObject)+import Indigo.Common.SIS (SomeIndigoState, runSIS)+import Indigo.Common.State+import Indigo.Common.Var import Indigo.Lorentz-import qualified Lorentz.Instr as L+import Lorentz.Instr qualified as L import Lorentz.Zip (ZipInstr, ZippedStack)-import Util.Type (type (++), KnownList, listOfTypesConcatAssociativityAxiom)+import Morley.Michelson.Typed.Instr.Internal.Proofs (assocThm)+import Morley.Util.Type (KnownList, type (++))  ---------------------------------------------------------------------------- -- External interface@@ -87,10 +95,10 @@ initLambdaStackVars (StorageLambda _) = initStackVars initLambdaStackVars (EffLambda _) = initStackVarsEff -type Lambda1Generic extra arg res = (arg : extra) :-> (RetOutStack res ++ extra)+type Lambda1Generic extra arg res = WrappedLambda (arg : extra) (RetOutStack res ++ extra)  type CreateLambda1CGeneric extra arg res =-  ( ScopeCodeGen res, KnownValue arg, Typeable extra+  ( ScopeCodeGen res, KnownValue arg, Typeable extra, KnownList extra   , ZipInstr (arg : extra)   , KnownValue (ZippedStack (arg ': extra))   , KnownValue (ZippedStack (RetOutStack res ++ extra))@@ -211,7 +219,8 @@     -- we have to materialise only fields used in the lambda     IndigoState $ \md@MetaData{..} ->       let storage = storageVar @st-          ops@(Var opsRefId) = operationsVar+          ops = operationsVar+          opsRefId = case ops of Var x -> x           gcStack = pushRef storage $ pushRef ops mdStack           fetchCode =             auxiliaryHook md "Fetching operations" (varActionGet opsRefId mdStack) #@@ -241,12 +250,13 @@  type ExecuteLambda1CGeneric extra arg res =   ( ScopeCodeGen res, KnownValue arg-  , KnownValue ((arg : extra) :-> (RetOutStack res ++ extra))+  , KnownValue (WrappedLambda (arg : extra) (RetOutStack res ++ extra))   , KnownList extra   , ZipInstr (arg : extra)   , KnownList (RetOutStack res ++ extra)   , ZipInstr (RetOutStack res ++ extra)   , Typeable (RetOutStack res ++ extra)+  , Typeable extra   , KnownValue (ZippedStack (RetOutStack res ++ extra))   ) @@ -265,16 +275,15 @@   -> Expr arg   -> IndigoState inp (RetOutStack res ++ inp) executeLambda1Generic vars allocateCleanup varF argm = IndigoState $ \md@MetaData{..} ->-  let GenCode allocStk allocate cleanup = usingIndigoState md allocateCleanup in-  let getArgs =+  let GenCode allocStk allocate cleanup = usingIndigoState md allocateCleanup+      getArgs =         auxiliaryHook md "Computing implicit lambda arguments" allocate #         (gcCode $           usingIndigoState (replStkMd md allocStk) $ do               exprHookState ("Computing lambda parameter: " <> pretty argm) (compileExpr argm)-              exprHookState "Fetching lambda" (compileExpr (V varF))) in-  case listOfTypesConcatAssociativityAxiom @(RetOutStack res) @extra @inp of-    Dict ->-      let code = getArgs #-                 L.execute @_ @_ @inp #-                 liftClear @res cleanup-      in finalizeStatement @res mdStack vars code+              exprHookState "Fetching lambda" (compileExpr (V varF)))+      code = getArgs #+              L.execute @_ @_ @inp #+              liftClear @res cleanup+              \\ assocThm @(RetOutStack res) @extra @inp+  in finalizeStatement @res mdStack vars code

@@ -0,0 +1,359 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{- |+This module contains the logic to lookup 'Var's in a stack and the actions to+manipulate it.++For efficiency, actions are implemented using Lorentz macros.+To do so every necessary constraint is checked at runtime.+-}++module Indigo.Backend.Lookup+  ( -- * Variable Lookup Actions+    varActionGet+  , varActionSet+  , varActionUpdate+  , varActionOperation++  -- * Vinyl manipulation helpers+  , rtake+  , rdrop+  ) where++import Data.Constraint (Dict(..), HasDict)+import Data.Singletons (Sing, SingI, withSingI)+import Data.Type.Equality (TestEquality(..))+import Data.Typeable (eqT, typeRep, (:~:)(..))+import Data.Vinyl ((<+>))+import Data.Vinyl.TypeLevel (type (++))+import Fmt (pretty)+import Prelude hiding (tail)++import Indigo.Common.Var+  (HasSideEffects, Ops, RefId, StackVars(..), StackVars', StkEl(..), Var(..), operationsVar)+import Indigo.Lorentz+import Lorentz.Instr qualified as L+import Lorentz.Macro qualified as L+import Morley.Michelson.Typed (ToTs)+import Morley.Michelson.Typed.Instr.Constraints qualified as MI+import Morley.Michelson.Typed.T qualified as MI+import Morley.Util.Peano+import Morley.Util.Sing++----------------------------------------------------------------------------+-- Variable Lookup Actions+----------------------------------------------------------------------------++-- | Puts a copy of the value for the given 'Var' on top of the stack+varActionGet :: forall a stk . KnownValue a => RefId -> StackVars stk -> stk :-> a : stk+varActionGet _ FailureStack = error "You try to get a cell on failure stack"+varActionGet ref (StkElements stk) = case varDepth @a ref stk of+  VarDepth n -> duupXVar n ref stk++-- | Sets the value for the given 'Var' to the topmost value on the stack+varActionSet :: forall a stk . KnownValue a => RefId -> StackVars stk -> a : stk :-> stk+varActionSet _ FailureStack = error "You try to set a cell on failure stack"+varActionSet ref (StkElements stk) = case varDepth @a ref stk of+  VarDepth n -> replaceNVar (SS n) ref (NoRef :& stk)++-- | Updates the value for the given 'Var' with the topmost value on the stack+-- using the given binary instruction.+varActionUpdate+  :: forall a b stk . (KnownValue a, KnownValue b)+  => RefId+  -> StackVars stk+  -> '[b, a] :-> '[a]+  -> (b ': stk) :-> stk+varActionUpdate _ FailureStack _ = error "You try to update a cell on failure stack"+varActionUpdate v (StkElements stk) instr = case varDepth @a v stk of+  VarDepth n -> updateNVar (SS n) v (NoRef :& stk) instr++-- | Given a stack with a list of 'Operation's on its bottom, updates it by+-- appending the 'Operation' on the top.+varActionOperation+  :: HasSideEffects+  => StackVars stk+  -> (Operation ': stk) :-> stk+varActionOperation s =+  case operationsVar of+    Var refId -> varActionUpdate @Ops refId s L.cons++----------------------------------------------------------------------------+-- Variable-based Macros+----------------------------------------------------------------------------++-- | Like 'varActionGet', but requires the depth of the 'Var' in the input stack+duupXVar+  :: forall inp a (m :: Peano).+     ( HasCallStack+     , KnownValue a+     )+  => Sing m -> RefId -> StackVars' inp -> inp :-> (a ': inp)+duupXVar m v stk =+  withVarMaybeDict (dupNLorentzConstraint n stk a out) $+  withDict (dupableConstraint a) $+    L.dupNPeano @('S m) @a @inp @(a ': inp)+  where+    a = Ref @a v+    n = SS m+    out = a :& stk++-- | Like 'varActionSet', but requires the depth of the 'Var' in the input stack+replaceNVar+  :: forall s a (n :: Peano) mid tail.+     ( HasCallStack+     , KnownValue a+     , mid ~ (Take n (a ': s) ++ Drop n s)+     , tail ~ Drop n s+     )+  => Sing n -> RefId -> StackVars' (a ': s) -> (a ': s) :-> s+replaceNVar n v stk@(_ :& s) =+  withVarMaybeDict (replaceNClassConstraint n s (Ref @a v) mid tail) $+    L.replaceNImpl @n @s @a @mid @tail+  where+    mid = rtake n stk <+> rdrop n s+    tail = rdrop n s++-- | Like 'varActionUpdate', but requires the depth of the 'Var' in the input stack+updateNVar+  :: forall s a b mid tail (n :: Peano).+     ( HasCallStack+     , KnownValue b+     , tail ~ Drop n s+     , mid ~ ((Drop ('S 'Z) (Take n (a ': s))) ++ (a ': Drop n (a ': s)))+     )+  => Sing n -> RefId -> StackVars' (a ': s)+  -> '[a, b] :-> '[b]+  -> (a ': s) :-> s+updateNVar n v stk@(a :& s) instr =+  withVarMaybeDict (updateNClassConstraint n s a (Ref @b v) mid tail) $+    L.updateNImpl @n @s @a @b @mid @tail instr+  where+    mid = rdrop (SS SZ) (rtake n stk) <+> a :& rdrop n stk+    tail = rdrop n s++withVarMaybeDict :: (HasDict c e, HasCallStack) => Maybe e -> (c => r) -> r+withVarMaybeDict mDict = withDict (fromMaybe (error constraintFailure) mDict)+  where+    -- NOTE: provided that the 'VarDepth' is correctly calculated every place+    -- where this is used should never result in a 'Nothing', as this is only+    -- necessary to prove to GHC properties that always hold.+    -- For this reason a failure here is always unexpected+    constraintFailure = "Unexpected failure in Var's constraint checking"++----------------------------------------------------------------------------+-- Variable's Depth+----------------------------------------------------------------------------++-- | Keeps the 0-indexed depth of a variable as a 'Peano' 'Sing'leton+data VarDepth where+  VarDepth :: Sing (idx :: Peano) -> VarDepth++-- | Calculates the 'VarDepth' of the given 'Var' in the stack+varDepth+  :: forall a s. KnownValue a+  => RefId+  -> StackVars' s+  -> VarDepth+varDepth refId = \case+  RNil -> error $+    "You are looking for manually created or leaked variable. " <>+    pretty refId <> " of type " <> show (typeRep (Proxy @a))+  stk@(_ :& _) -> varDepthNonEmpty @a refId stk++varDepthNonEmpty+  :: forall a s x xs. (KnownValue a, s ~ (x : xs))+  => RefId -> StackVars' s -> VarDepth+varDepthNonEmpty ref (x :& xs) = case x of+  Ref topRef | ref == topRef -> case eqT @a @x of+    Just Refl -> VarDepth SZ+    Nothing   -> error $+      "Invalid variable type. " <> pretty ref <>+      ".\nWas looking for a " <> show (typeRep $ Proxy @a) <>+      ", but found a: " <> show (typeRep $ Proxy @x)+  _ -> case varDepth @a ref xs of+    VarDepth idx -> VarDepth (SS idx)++----------------------------------------------------------------------------+-- Macro class constraints+----------------------------------------------------------------------------++replaceNClassConstraint+  :: Sing n -> StackVars' s -> StkEl a -> StackVars' mid -> StackVars' tail+  -> Maybe (Dict (L.ReplaceN n s a mid tail))+replaceNClassConstraint n s a mid tail = case n of+  SZ -> Nothing+  SS SZ -> case s of+    (x :& _xs) -> do+      Refl <- testEquality x a+      return Dict+    _ -> Nothing+  SS (SS m) -> do+    Dict <- replaceNLorentzConstraint (SS m) s a mid tail+    return $ withSingI m $ Dict++updateNClassConstraint+  :: Sing n -> StackVars' s -> StkEl a -> StkEl b -> StackVars' mid -> StackVars' tail+  -> Maybe (Dict (L.UpdateN n s a b mid tail))+updateNClassConstraint n s a b mid tail = case n of+  SZ -> Nothing+  SS SZ -> case s of+    (x :& xs) -> do+      Refl <- testEquality x b+      Refl <- testEquality xs tail+      return Dict+    _ -> Nothing+  SS (SS SZ) -> case s of+    (_x :& y :& xs) -> do+      Refl <- testEquality y b+      Refl <- testEquality xs tail+      return Dict+    _ -> Nothing+  SS (SS (SS m)) -> do+    Dict <- updateNLorentzConstraint (SS (SS m)) s a b mid tail+    return $ withSingI m $ Dict++----------------------------------------------------------------------------+-- Lorentz constraints+----------------------------------------------------------------------------++dupableConstraint+  :: (KnownValue a, HasCallStack)+  => StkEl a+  -> Dict (Dupable a)+dupableConstraint (_ :: StkEl a) =+  case decideOnDupable @a of+    IsDupable -> Dict+    IsNotDupable ->+      error "Non-dupable values (like tickets) are not supported yet"++dupNLorentzConstraint+  :: Sing n -> StackVars' inp -> StkEl a -> StackVars' out+  -> Maybe (Dict (L.ConstraintDUPNLorentz n inp out a))+dupNLorentzConstraint n inp a out = do+  Dict <- dupNConstraint n inp out a+  Dict <- dupNConstraint n (toTVals inp) (toTVals out) (toTVal a)+  return $ withSingI n $ Dict++updateNLorentzConstraint+  :: Sing n -> StackVars' s -> StkEl a -> StkEl b -> StackVars' mid -> StackVars' tail+  -> Maybe (Dict (L.ConstraintUpdateNLorentz n s a b mid tail))+updateNLorentzConstraint n s a b mid tail = do+  Refl <- testEquality tail (rdrop (SS n) s)+  Refl <- testEquality (toTVals tail) (rdrop (SS n) (toTVals s))+  Dict <- dugLorentzConstraint n (a :& s) mid a+  Dict <- dipNLorentzConstraint n mid s (a :& b :& tail) (b :& tail)+  return Dict++replaceNLorentzConstraint+  :: Sing n -> StackVars' s -> StkEl a -> StackVars' mid -> StackVars' tail+  -> Maybe (Dict (L.ConstraintReplaceNLorentz n s a mid tail))+replaceNLorentzConstraint n s a mid tail = do+  Refl <- testEquality tail (rdrop (SS n) s)+  Refl <- testEquality (toTVals tail) (rdrop (SS n) (toTVals s))+  Dict <- dipNLorentzConstraint (SS n) (a :& s) mid (a :& tail) tail+  Dict <- dugLorentzConstraint n mid s a+  return $ Dict++dugLorentzConstraint+  :: Sing n -> StackVars' inp -> StackVars' out -> StkEl a+  -> Maybe (Dict (L.ConstraintDUGLorentz n inp out a))+dugLorentzConstraint n inp out a = do+  Dict <- dugConstraint n inp out a+  Dict <- dugConstraint n (toTVals inp) (toTVals out) (toTVal a)+  return $ withSingI n $ Dict++dipNLorentzConstraint+  :: Sing n -> StackVars' inp -> StackVars' out -> StackVars' s -> StackVars' s'+  -> Maybe (Dict (L.ConstraintDIPNLorentz n inp out s s'))+dipNLorentzConstraint n inp out s s' = do+  Dict <- dipNConstraint n inp out s s'+  Dict <- dipNConstraint n (toTVals inp) (toTVals out) (toTVals s) (toTVals s')+  return $ withSingI n $ Dict++----------------------------------------------------------------------------+-- Morley constraints+----------------------------------------------------------------------------++dupNConstraint+  :: TestEquality any+  => Sing n -> Rec any inp -> Rec any out -> any a+  -> Maybe (Dict (MI.ConstraintDUPN' kind n inp out a))+dupNConstraint n inp out a = do+  Dict <- requireLongerOrSameLength inp n+  Dict <- isGreaterThan n SZ+  decN <- peanoSingDecrement n+  Refl <- testEquality inp ((lazyRtake decN inp) <+> a :& rdrop n inp)+  Refl <- testEquality out (a :& inp)+  return Dict++dugConstraint+  :: TestEquality any+  => Sing n -> Rec any inp -> Rec any out -> any a+  -> Maybe (Dict (MI.ConstraintDUG' kind n inp out a))+dugConstraint n inp out a = do+  Dict <- requireLongerThan out n+  Refl <- testEquality (a :& rdrop (SS SZ) inp) inp+  Refl <- testEquality (lazyRtake n out <+> rdrop (SS n) out) (rdrop (SS SZ) inp)+  Refl <- testEquality (lazyRtake n (rdrop (SS SZ) inp) <+> a :& rdrop n (rdrop (SS SZ) inp)) out+  return Dict++dipNConstraint+  :: TestEquality any+  => Sing n -> Rec any inp -> Rec any out -> Rec any s -> Rec any s'+  -> Maybe (Dict (MI.ConstraintDIPN' kind n inp out s s'))+dipNConstraint n inp out s s' = do+  Dict <- requireLongerOrSameLength inp n+  Refl <- testEquality (lazyRtake n inp <+> s) inp+  Refl <- testEquality (lazyRtake n inp <+> s') out+  Refl <- testEquality (rdrop n inp) s+  Refl <- testEquality (rdrop n out) s'+  return Dict++----------------------------------------------------------------------------+-- Conversion for ToT constraints+----------------------------------------------------------------------------++-- | Stack representation of 'MI.T' used for constraint checking+type TValStack (stk :: [MI.T]) = Rec TVal stk++-- | Simple datatype used to keep a 'MI.T' and its 'SingI' constraint+data TVal (a :: MI.T) where+  TVal :: SingI a => TVal a++instance TestEquality TVal where+  testEquality (TVal :: TVal a) (TVal :: TVal b) = eqI @a @b++toTVal :: forall a. StkEl a -> TVal (ToT a)+toTVal = \case+  NoRef -> TVal @(ToT a)+  Ref _ -> TVal @(ToT a)++toTVals :: StackVars' stk -> TValStack (ToTs stk)+toTVals = \case+  RNil          -> RNil+  (NoRef :& xs) -> TVal :& toTVals xs+  (Ref _ :& xs) -> TVal :& toTVals xs++----------------------------------------------------------------------------+-- Vinyl manipulation helpers+----------------------------------------------------------------------------++rtake :: Sing n -> Rec any s -> Rec any (Take n s)+rtake sn stk = case (sn, stk) of+  (SZ, _)           -> RNil+  (SS n, (x :& xs)) -> x :& rtake n xs+  (SS _, RNil)      -> error "given stack is too small"++lazyRtake :: Sing n -> Rec any s -> Rec any (LazyTake n s)+lazyRtake sn stk = case (sn, stk) of+  (SZ, _)           -> RNil+  (SS n, (x :& xs)) -> x :& lazyRtake n xs+  (SS _, RNil)      -> error "given stack is too small"++rdrop :: Sing n -> Rec any s -> Rec any (Drop n s)+rdrop sn stk = case (sn, stk) of+  (SZ, _)           -> stk+  (SS n, (_ :& xs)) -> rdrop n xs+  (SS _, RNil)      -> error "given stack is too small"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -45,17 +44,18 @@   , prettyRet   ) where -import qualified Data.Kind as Kind+import Data.Kind qualified as Kind import Fmt (Buildable(..), pretty)-import qualified GHC.TypeLits as Lit-import Util.Type (type (++))+import GHC.TypeLits qualified as Lit +import Indigo.Backend.Expr.Compilation (compileExpr) import Indigo.Backend.Prelude-import Indigo.Internal.Expr hiding ((<>))-import Indigo.Internal.State-import Indigo.Internal.Var+import Indigo.Common.Expr (Expr, ExprType, ToExpr, toExpr)+import Indigo.Common.State+import Indigo.Common.Var import Indigo.Lorentz-import qualified Lorentz.Instr as L+import Lorentz.Instr qualified as L+import Morley.Util.Type (type (++))  -- | To avoid overlapping instances we need to somehow distinguish single values -- from tuples, because the instances:@@ -269,8 +269,7 @@          , Buildable (RetVars' 'Tuple (x, y))          ) => ScopeCodeGen' 'Tuple (x, y) where   compileScopeReturn' (e1, e2) = compileToExpr e2 >> compileToExpr e1-  -- TODO is L.dip . L.dip cheaper than L.dipN ?-  liftClear' = L.dip . L.dip+  liftClear' = L.dipN @2   genGcClear' = L.drop # L.drop  instance ( KnownValueExpr x

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Backend statements for variable manipulation: assignment, replacement, update. @@ -13,13 +12,20 @@  import Fmt (pretty) +import Indigo.Backend.Expr.Compilation (binaryOpFlat, compileExpr, unaryOpFlat)+import Indigo.Backend.Expr.Decompose (ExprDecomposition(Deconstructed, ExprFields), decomposeExpr)+import Indigo.Backend.Lookup (varActionSet, varActionUpdate) import Indigo.Backend.Prelude import Indigo.Backend.Scope-import Indigo.Internal hiding ((+), (<>))+import Indigo.Common.Expr (Expr(V))+import Indigo.Common.Field (FieldLens(DeeperField, TargetField), HasField(..), fetchField, flSFO)+import Indigo.Common.Object+import Indigo.Common.State+import Indigo.Common.Var (RefId, Var(..)) import Indigo.Lorentz-import qualified Lorentz.Instr as L-import Michelson.Typed.Haskell.Instr.Product (GetFieldType)-import Util.Type (type (++))+import Lorentz.Instr qualified as L+import Morley.Michelson.Typed.Haskell.Instr.Product (GetFieldType)+import Morley.Util.Type (type (++))  -- | Assign the given variable to the value resulting from the given expression. assignVar :: forall x inp . KnownValue x => Var x -> Expr x -> IndigoState inp (x : inp)@@ -91,7 +97,9 @@     withObjectState v setFieldImpl   where     setFieldImpl :: forall x . (IsObject x, HasField x fname ftype) => Object x -> IndigoState inp inp-    setFieldImpl (Cell refId) = updateVar @x nextRef (sopSetField (flSFO fieldLens) targetLb) (Var refId) e+    setFieldImpl (Cell refId) =+      updateVar @x nextRef (sopSetField (flSFO fieldLens)+        (fieldNameFromLabel targetLb)) (Var refId) e     setFieldImpl (Decomposed fields) = case fieldLens @x @fname @ftype of       TargetField lb _ ->         case fetchField @x lb fields of

@@ -0,0 +1,520 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_GHC -Wno-orphans #-}++-- | 'Expr' data type and its generalizations++module Indigo.Common.Expr+  ( -- * The Expr data type+    Expr (..)++  -- * Generalizations of Expr+  , IsExpr+  , ToExpr+  , ExprType+  , (:~>)+  , toExpr++  -- * Arithmetic Expr+  , IsArithExpr+  , IsUnaryArithExpr++  -- * Polymorphic Expr+  , IsConcatExpr+  , IsConcatListExpr+  , IsDivExpr+  , IsModExpr+  , IsGetExpr+  , IsMemExpr+  , IsSizeExpr+  , IsSliceExpr+  , IsUpdExpr++  , ObjectManipulation (..)+  , ObjectExpr+  , NamedFieldExpr (..)+  ) where++import Data.Kind qualified as Kind+import Data.Typeable (typeRep)+import Data.Vinyl.Core (RMap(..), RecordToList(..))+import Data.Vinyl.Functor (Const(..))+import Fmt (Buildable(..), pretty)+import Prelude hiding (Const(..))++import Indigo.Common.Expr.TH (deriveExprBuildable)+import Indigo.Common.Field+import Indigo.Common.Object (ComplexObjectC, FieldTypes, IndigoObjectF(..))+import Indigo.Common.Var (Var(..))+import Indigo.Lorentz+import Morley.Michelson.Typed (CtorOnlyField, GetFieldType, InstrUnwrapC, InstrWrapOneC)+import Morley.Michelson.Typed.Arith qualified as M++----------------------------------------------------------------------------+-- The Expr data type+----------------------------------------------------------------------------++data Expr a where+  C :: NiceConstant a => a -> Expr a++  V :: KnownValue a => Var a -> Expr a++  ObjMan :: ObjectManipulation a -> Expr a++  Cast :: KnownValue a => Expr a -> Expr a++  Size :: SizeOpHs c => Expr c -> Expr Natural++  Update+    :: (UpdOpHs c, KnownValue c)+    => Expr c -> Expr (UpdOpKeyHs c) -> Expr (UpdOpParamsHs c) -> Expr c++  Add+    :: (ArithOpHs M.Add n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Sub+    :: (ArithOpHs M.Sub n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Mul+    :: (ArithOpHs M.Mul n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Div+    :: ( KnownValue ratio+       , ArithOpHs M.EDiv n m (Maybe (ratio, reminder))+       )+    => Expr n -> Expr m -> Proxy reminder -> Expr ratio++  Mod+    :: ( KnownValue reminder+       , ArithOpHs M.EDiv n m (Maybe (ratio, reminder))+       )+    => Expr n -> Expr m -> Proxy ratio -> Expr reminder++  Abs+    :: (UnaryArithOpHs M.Abs n, KnownValue (UnaryArithResHs M.Abs n))+    => Expr n -> Expr (UnaryArithResHs M.Abs n)++  Neg+    :: (UnaryArithOpHs M.Neg n, KnownValue (UnaryArithResHs M.Neg n))+    => Expr n -> Expr (UnaryArithResHs M.Neg n)+++  Lsl+    :: (ArithOpHs M.Lsl n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Lsr+    :: (ArithOpHs M.Lsr n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r+++  Eq' :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Neq :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Le :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Lt :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Ge :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Gt :: NiceComparable n => Expr n -> Expr n -> Expr Bool++  Or+    :: (ArithOpHs M.Or n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Xor+    :: (ArithOpHs M.Xor n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  And+    :: (ArithOpHs M.And n m r, KnownValue r)+    => Expr n -> Expr m -> Expr r++  Not+    :: (UnaryArithOpHs M.Not n, KnownValue (UnaryArithResHs M.Not n))+    => Expr n -> Expr (UnaryArithResHs M.Not n)++  Int' :: Expr Natural -> Expr Integer++  IsNat :: Expr Integer -> Expr (Maybe Natural)++  Coerce+    :: (Castable_ a b, KnownValue b)+    => Expr a -> Expr b++  ForcedCoerce+    :: (MichelsonCoercible a b, KnownValue b)+    => Expr a -> Expr b++  Fst :: KnownValue n => Expr (n, m) -> Expr n+  Snd :: KnownValue m => Expr (n, m) -> Expr m++  Pair :: KnownValue (n, m) => Expr n -> Expr m -> Expr (n, m)++  Some :: KnownValue (Maybe t) => Expr t -> Expr (Maybe t)+  None :: KnownValue t => Expr (Maybe t)++  Right' :: (KnownValue y, KnownValue (Either y x)) => Expr x -> Expr (Either y x)+  Left' :: (KnownValue x, KnownValue (Either y x)) => Expr y -> Expr (Either y x)++  Mem :: MemOpHs c => Expr (MemOpKeyHs c) -> Expr c -> Expr Bool++  StGet+    :: ( StoreHasSubmap store name key value+       , KnownValue value+       )+    => Label name -> Expr key -> Expr store -> Expr (Maybe value)++  StInsertNew+    :: ( StoreHasSubmap store name key value+       , KnownValue store+       , Dupable key+       , IsError err+       , Buildable err+       )+    => Label name -> err+    -> Expr key -> Expr value -> Expr store -> Expr store++  StInsert+    :: (StoreHasSubmap store name key value, KnownValue store)+    => Label name+    -> Expr key -> Expr value -> Expr store -> Expr store++  StMem+    :: ( StoreHasSubmap store name key val+       , KnownValue val+       )+    => Label name -> Expr key -> Expr store -> Expr Bool++  StUpdate+    :: (StoreHasSubmap store name key val, KnownValue store)+    => Label name -> Expr key -> Expr (Maybe val) -> Expr store -> Expr store++  StDelete+    :: (StoreHasSubmap store name key val, KnownValue store, KnownValue val)+    => Label name -> Expr key -> Expr store -> Expr store++  Wrap+    :: ( InstrWrapOneC dt name+       , KnownValue dt+       )+    => Label name+    -> Expr (CtorOnlyField name dt)+    -> Expr dt+  Unwrap+    :: ( InstrUnwrapC dt name+       , KnownValue (CtorOnlyField name dt)+       )+    => Label name+    -> Expr dt+    -> Expr (CtorOnlyField name dt)++  Construct+    :: ( InstrConstructC dt+       , RMap (ConstructorFieldTypes dt)+       , RecordToList (ConstructorFieldTypes dt)+       , KnownValue dt+       )+    => Proxy dt -> Rec Expr (ConstructorFieldTypes dt) -> Expr dt++  -- TODO remove Construct and rename this one+  ConstructWithoutNamed+    :: ComplexObjectC dt+    => Proxy dt -> Rec Expr (FieldTypes dt) -> Expr dt++  Name+    :: KnownValue (name :! t)+    => Label name -> Expr t -> Expr (name :! t)+  UnName+    :: KnownValue t+    => Label name -> Expr (name :! t) -> Expr t++  EmptySet+    :: (NiceComparable key, KnownValue (Set key))+    => Expr (Set key)++  Get+    :: ( GetOpHs c+       , KnownValue (Maybe (GetOpValHs c))+       , KnownValue (GetOpValHs c)+       )+    => Expr (GetOpKeyHs c) -> Expr c -> Expr (Maybe (GetOpValHs c))++  EmptyMap+    :: (KnownValue value, NiceComparable key, KnownValue (Map key value))+    => Expr (Map key value)++  EmptyBigMap+    :: (KnownValue value, NiceComparable key, KnownValue (BigMap key value))+    => Expr (BigMap key value)++  Pack+    :: NicePackedValue a+    => Expr a -> Expr (Packed a)++  Unpack+    :: NiceUnpackedValue a+    => Expr (Packed a) -> Expr (Maybe a)++  PackRaw+    :: NicePackedValue a+    => Expr a -> Expr ByteString++  UnpackRaw+    :: NiceUnpackedValue a+    => Expr ByteString -> Expr (Maybe a)++  Cons :: KnownValue (List a) => Expr a -> Expr (List a) -> Expr (List a)++  Nil :: KnownValue a => Expr (List a)++  Concat+    :: (ConcatOpHs c, KnownValue c)+    => Expr c -> Expr c -> Expr c++  Concat'+    :: (ConcatOpHs c, KnownValue c)+    => Expr (List c) -> Expr c++  Slice+    :: (SliceOpHs c, KnownValue c)+    => Expr Natural -> Expr Natural -> Expr c -> Expr (Maybe c)++  Contract+    :: ( NiceParameterFull p+       , NoExplicitDefaultEntrypoint p+       , IsoValue (ContractRef p)+       , ToTAddress p vd addr+       , ToT addr ~ ToT Address+       )+    => Proxy vd -> Expr addr -> Expr (Maybe (ContractRef p))++  Self+    :: ( NiceParameterFull p+       , NoExplicitDefaultEntrypoint p+       , IsoValue (ContractRef p)+       , IsNotInView+       )+    => Expr (ContractRef p)++  SelfAddress+    :: Expr Address++  ContractAddress+    :: Expr (ContractRef p) -> Expr Address++  ContractCallingUnsafe+    :: (NiceParameter arg, IsoValue (ContractRef arg))+    => EpName -> Expr Address -> Expr (Maybe (ContractRef arg))++  RunFutureContract+    :: (NiceParameter p, IsoValue (ContractRef p))+    => Expr (FutureContract p) -> Expr (Maybe (ContractRef p))++  ImplicitAccount :: Expr KeyHash -> Expr (ContractRef ())++  ConvertEpAddressToContract+    :: (NiceParameter p, IsoValue (ContractRef p))+    => Expr EpAddress -> Expr (Maybe (ContractRef p))++  MakeView+    :: KnownValue (View_ a r)+    => Expr a -> Expr (ContractRef r) -> Expr (View_ a r)++  MakeVoid+    :: KnownValue (Void_ a b)+    => Expr a -> Expr (Lambda b b) -> Expr (Void_ a b)++  CheckSignature+    :: BytesLike bs => Expr PublicKey -> Expr (TSignature bs) -> Expr bs -> Expr Bool++  Sha256 :: BytesLike bs => Expr bs -> Expr (Hash Sha256 bs)+  Sha512 :: BytesLike bs => Expr bs -> Expr (Hash Sha512 bs)+  Blake2b :: BytesLike bs => Expr bs -> Expr (Hash Blake2b bs)+  Sha3 :: BytesLike bs => Expr bs -> Expr (Hash Sha3 bs)+  Keccak :: BytesLike bs => Expr bs -> Expr (Hash Keccak bs)+  HashKey :: Expr PublicKey -> Expr KeyHash++  ChainId :: Expr ChainId+  Level :: Expr Natural++  Now :: Expr Timestamp+  Amount :: Expr Mutez+  Balance :: Expr Mutez+  Sender :: Expr Address+  VotingPower :: Expr KeyHash -> Expr Natural+  TotalVotingPower :: Expr Natural++  -- TODO [#832]: add 4 ticket instructions++  Exec+    :: KnownValue b+    => Expr a -> Expr (Lambda a b) -> Expr b++  NonZero+    :: (NonZero n, KnownValue (Maybe n))+    => Expr n -> Expr (Maybe n)++----------------------------------------------------------------------------+-- Object manipulation+----------------------------------------------------------------------------++-- | Datatype describing access to an inner fields of object, like+-- @object !. field1 !. field2 ~. (field3, value3) ~. (field4, value4)@+data ObjectManipulation a where+  Object :: Expr a -> ObjectManipulation a++  ToField+    :: HasField dt fname ftype+    => ObjectManipulation dt+    -> Label fname+    -> ObjectManipulation ftype++  -- NB. @SetField (Object expr) field1+  --       (ObjMan $ SetField (ToField (Object expr) field1) field2 targetExpr)@+  -- is a bad representation, which will cause generation of not optimal code+  -- (like expr would be materialized object),+  -- so it would be nice to enforce only+  -- @SetField (Object expr) (field1 . field2) targetExpr@ representation.+  SetField+    :: HasField dt fname ftype+    => ObjectManipulation dt+    -> Label fname+    -> Expr ftype+    -> ObjectManipulation dt++deriveExprBuildable ''Expr++instance Buildable (ObjectManipulation a) where+  build (Object e) = build e+  build (ToField oman lab) = pretty oman <> " #! " <> pretty lab+  build (SetField oman lab fEx) = pretty oman <> " !! (" <> pretty lab <> ", " <> pretty fEx <> ")"++-- | Auxiliary datatype where each field refers to+-- an expression the field equals to. It's not recursive one.+data NamedFieldExpr a name where+  NamedFieldExpr+    :: { unNamedFieldExpr :: Expr (GetFieldType a name) }+    -> NamedFieldExpr a name++type ObjectExpr a = IndigoObjectF (NamedFieldExpr a) a++----------------------------------------------------------------------------+-- Generalizations of Expr+----------------------------------------------------------------------------++type IsExpr op n = (ToExpr op, ExprType op ~ n, KnownValue n)+type (:~>) op n = IsExpr op n++type ExprType a = ExprType' (Decide a) a++toExpr :: forall a . ToExpr a => a -> Expr (ExprType a)+toExpr = toExpr' @(Decide a) @a++class ToExpr' (Decide x) x => ToExpr x+instance ToExpr' (Decide x) x => ToExpr x++-- This type class is needed to cope with overlapping instances.+class ToExpr' decision c where+  type family ExprType' decision c :: Kind.Type+  toExpr' :: c -> Expr (ExprType' decision c)++-- Instance for a var+instance KnownValue (a :: Kind.Type) => ToExpr' 'VarD (Var a) where+  type instance ExprType' 'VarD (Var a) = a+  toExpr' = V++-- Instance for a value+instance NiceConstant a => ToExpr' 'ValD a where+  type instance ExprType' 'ValD a = a+  toExpr' = C++-- Instance for StructManipulation+instance ToExpr' 'ObjManD (ObjectManipulation a) where+  type instance ExprType' 'ObjManD (ObjectManipulation a) = a+  toExpr' = ObjMan++-- Instance for Expr itself+instance ToExpr' 'ExprD (Expr a) where+  type instance ExprType' 'ExprD (Expr a) = a+  toExpr' = id++data Decision = VarD | ValD | ExprD | ObjManD++type family Decide x :: Decision where+  Decide (Var _) = 'VarD+  Decide (Expr _) = 'ExprD+  Decide (ObjectManipulation _) = 'ObjManD+  Decide _ = 'ValD++type IsUnaryArithExpr exN a n =+  ( exN :~> n+  , UnaryArithOpHs a n+  , KnownValue (UnaryArithResHs a n)+  )++type IsArithExpr exN exM a n m r =+  ( exN :~> n, exM :~> m+  , ArithOpHs a n m r+  , KnownValue r+  )++type IsDivExpr exN exM n m ratio reminder =+  ( exN :~> n, exM :~> m+  , KnownValue ratio+  , ArithOpHs M.EDiv n m (Maybe (ratio, reminder))+  )++type IsModExpr exN exM n m ratio reminder =+  ( exN :~> n, exM :~> m+  , KnownValue reminder+  , ArithOpHs M.EDiv n m (Maybe (ratio, reminder))+  )++type IsConcatExpr exN1 exN2 n =+  ( exN1 :~> n+  , exN2 :~> n+  , ConcatOpHs n+  )++type IsConcatListExpr exN n =+  ( exN :~> List n+  , ConcatOpHs n+  , KnownValue n+  )++type IsSliceExpr exN n =+  ( exN :~> n+  , SliceOpHs n+  )++type IsGetExpr exKey exMap map =+  ( exKey :~> GetOpKeyHs map+  , exMap :~> map+  , GetOpHs map+  , KnownValue (GetOpValHs map)+  )++type IsUpdExpr exKey exVal exMap map =+  ( exKey :~> UpdOpKeyHs map+  , exVal :~> UpdOpParamsHs map+  , exMap :~> map+  , UpdOpHs map+  )++type IsMemExpr exKey exN n =+  ( exKey :~> MemOpKeyHs n+  , exN :~> n+  , MemOpHs n+  )++type IsSizeExpr exN n =+  ( exN :~> n+  , SizeOpHs n+  )

@@ -0,0 +1,165 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# LANGUAGE QuasiQuotes #-}++-- | TH utilities used in "Indigo.Common.Expr"+module Indigo.Common.Expr.TH+       ( deriveExprBuildable+       ) where++import Data.Map qualified as M+import Data.Set qualified as S+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax qualified as TH+import Prelude hiding (Const)+import Text.Casing qualified as C++pattern CName :: String -> (TH.Name, [BangType])+pattern CName nm <- (TH.Name (OccName nm) _, _)++type UntypedConstr = (Name, [BangType])++-- | Generates an Buildable instance for a Expr GADT. /Note:/ This will not generate+-- additional constraints to the generated instance if those are required.+-- Inspired by 'deriveGADTNFData' from Util.TH.+deriveExprBuildable :: Name -> Q [Dec]+deriveExprBuildable name = do+  TyConI (DataD _ dataName vars _ cons _) <- reify name++  let getNameFromVar (PlainTV n _) = n+      getNameFromVar (KindedTV n _ _) = n+      convertTyVars orig = foldr (\a b -> AppT b . VarT $ getNameFromVar a) orig vars++      -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff"+      -- into a list of tuples of constructor names and their data+      unfoldConstructor (GadtC cs bangs _) = map (,bangs) cs+      unfoldConstructor (ForallC _ _ c) = unfoldConstructor c+      unfoldConstructor _ = fail "Non GADT constructors are not supported."++      (bLeft, bRight, comma) = (LitE (StringL "("), LitE (StringL ")"), LitE (StringL ", "))++      mappendAll :: [Exp] -> Exp+      mappendAll [] = error "impossible empty list"+      mappendAll (hd : rest) = foldl (\res term -> InfixE (Just res) (VarE (mkName "<>")) (Just term)) hd rest++      omitUnaryConstr :: (Exp -> Exp) -> UntypedConstr -> Q Clause+      omitUnaryConstr fun (conName, _) = do+        var <- newName "a"+        return $+          Clause+            [ConP conName [VarP var]]+            (NormalB $ fun (VarE var))+            []++      -- Specific to Expr+      toFunName (CName "Right'") = "right"+      toFunName (CName "Left'")  = "left"+      toFunName (CName "Concat'") = "concatAll"+      toFunName (CName "Int'")  = "toInt"+      toFunName (TH.Name (OccName nm) _, _) = C.toCamel $ C.fromHumps nm++      operators :: Map String String+      operators = M.fromList [ ("Add", "+"), ("Sub", "-"), ("Mul", "*"), ("Div", "/"), ("Mod", "%")+                             , ("Lsl", "<<<"), ("Lsr", ">>>"), ("Eq'", "=="), ("Neq", "/="), ("Le", "=<")+                             , ("Lt", "<"), ("Ge", ">="), ("Gt", ">="), ("Or", "||"), ("Xor", "^"), ("And", "&&")+                             , ("Cons", ".:"), ("Concant", "<>")+                             ]++      braces :: Set String+      braces = S.fromList ["Add", "Sub", "Or", "Xor", "Lsl", "Lsr"]++      makeClause :: UntypedConstr -> Q Clause+      makeClause c@(CName "C") = omitUnaryConstr (AppE (VarE $ mkName "pretty") . AppE (ConE $ mkName "PrintAsValue")) c+      makeClause c@(CName "V") = omitUnaryConstr (AppE (VarE $ mkName "pretty")) c+      makeClause c@(CName "Div") = constructBinaryOperatorWithProxy c+      makeClause c@(CName "Mod") = constructBinaryOperatorWithProxy c+      makeClause c@(CName "Contract") = constructUnaryWithProxy c+      makeClause c@(CName "ObjMan") = omitUnaryConstr (AppE (VarE $ mkName "pretty")) c+      makeClause c@(CName "Construct") = construct c+      makeClause c@(CName "ConstructWithoutNamed") = construct c+      makeClause c@(CName "StInsertNew") =+        generalClauseImpl "pretty" c Nothing+      makeClause c@(TH.Name (OccName nm) _, _) =+        generalClauseImpl "pretty" c $ (, S.member nm braces) <$> M.lookup nm operators++      -- Construct build instance for operators that have several proxy values+      constructBinaryOperatorWithProxy (conName, bangs) = do+        x <- newName "a"+        y <- newName "a"+        let nm = nameBase conName+            op = fromMaybe (error "Unknown operator") $ M.lookup nm operators+            var_x = AppE (VarE $ mkName "pretty") (VarE x)+            var_y = AppE (VarE $ mkName "pretty") (VarE y)+            wilds = map (\_ -> WildP) (drop 2 bangs)+            varList = (map VarP [x, y]) ++ wilds++            pretties = [var_x, LitE (StringL $ " " <> op <> " "), var_y]++        return $+          Clause+            [ConP conName varList]+            (NormalB $ mappendAll pretties)+            []++      -- Construct build instance for constructors with a single argument preceeded+      -- by a single proxy+      constructUnaryWithProxy (conName, _bangs) = do+        x <- newName "a"+        let var_x = AppE (VarE $ mkName "pretty") (VarE x)+        return $+          Clause+            [ConP conName [WildP, VarP x]]+            (NormalB  var_x)+            []+++      construct (conName, _) = do+        proxy <- newName "proxy"+        r <- newName "rec"+        let showTypeRep = AppE (VarE $ mkName "show") . AppE (VarE $ mkName "typeRep")+        mappendRec <- [| \x -> mconcat (intersperse "," (recordToList (rmap (\ex -> Const (pretty ex)) x))) |]+        return $+          Clause+            [ConP conName [VarP proxy, VarP r]]+            (NormalB $+              mappendAll [showTypeRep (VarE proxy), bLeft, (AppE mappendRec (VarE r)), bRight])+            []++      -- Constructs a clause "build (ConName a1 a2) = "CON_NAME" <> "(" <> pretty a1 <> pretty a2 <> ")"+      -- The first argument is a workaround: it returns name of printing function either "pretty" or "show"+      -- by index argument.+      -- This is mainly for 'StInsertNew' constructor to print error with show+      generalClauseImpl :: String -> (Name, [BangType]) -> Maybe (String, Bool) -> Q Clause+      generalClauseImpl funName c@(conName, bangs) isInfix = do+        varNames <- traverse (\_ -> newName "a") bangs++        -- useful constants+        let funStr = LitE (StringL $ toFunName c)+        let pretties =+              case map (\e -> AppE (VarE $ mkName funName) (VarE e)) varNames of+                -- Nullary operator: "function_name"+                []    -> [funStr]+                -- Infix binary operator without braces: pretty x <> " operator " <> pretty y+                [x, y] | Just (op, False) <- isInfix ->+                  [x, LitE (StringL $ " " <> op <> " "), y]+                -- Infix binary operator with braces: "(" <> pretty x <> " operator " <> pretty y <> ")"+                [x, y] | Just (op, True) <- isInfix ->+                  [bLeft, x, LitE (StringL $ " " <> op <> " "), y, bRight]+                -- Infix binary operator with braces: "function_name" <> "(" <> pretty x1 <> "," ... <> pretty xn <> ")"+                xs -> funStr : bLeft : (intersperse comma xs ++ [bRight])+        return $+          Clause+            [ConP conName (map VarP varNames)]+            (NormalB $ mappendAll pretties)+            []++  clauses <- traverse makeClause $ cons >>= unfoldConstructor+  return+    [ InstanceD+        Nothing+        []+        (AppT (ConT $ mkName "Buildable") (convertTyVars $ ConT dataName))+        [FunD (mkName "build") clauses]+    ]

@@ -0,0 +1,136 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{- | This module contains a datatype representing a lens to a field,+helpers to compose new lens, and type class like StoreHasField returning a lens. -}++module Indigo.Common.Field+       ( AccessFieldC+       , fetchField+       , assignField++       -- * Lens+       , FieldLens (..)+       , flSFO+       -- * HasLens+       , HasField (..)+       , fieldLensDeeper+       , fieldLensADT+       ) where++import Data.Vinyl (RElem)+import Data.Vinyl.Lens (rget, rput)+import Data.Vinyl.TypeLevel (RIndex)+import GHC.TypeLits (KnownSymbol)++import Indigo.Lorentz+import Indigo.Prelude+import Lorentz.ADT qualified as L+import Morley.Michelson.Typed.Haskell.Instr.Product+  (ConstructorFieldNames, GetFieldType, InstrGetFieldC, InstrSetFieldC)++-- | Constraint to access/assign field stored in Rec+type AccessFieldC a name =+  RElem name (ConstructorFieldNames a) (RIndex name (ConstructorFieldNames a))++-- | Get a field from list of fields+fetchField+  :: forall a name f proxy . AccessFieldC a name+  => proxy name -> Rec f (ConstructorFieldNames a) -> f name+fetchField _ = rget @name++-- | Assign a field to a value+assignField+  :: forall a name f proxy . AccessFieldC a name+  => proxy name -> f name -> Rec f (ConstructorFieldNames a) -> Rec f (ConstructorFieldNames a)+assignField _ = rput @_ @name++-- | Lens to a field.+-- @obj.f1.f2.f3@ is represented as list names of @[f1, f2, f3]@.+--+-- @dt@ is a type of source object (type of obj in example above)+-- @fname@ is a name of target field (@"f3"@ in example above)+-- @ftype@ is a type of target field+--+-- However, a lens contains not only name of field+-- but for each field it contains operations to get and set+-- target field.+data FieldLens dt fname ftype where+  -- Direct field of @dt@ (which is target one).+  -- Pay attention that it holds a label of existential type @fname@ but not @targetFName@.+  -- It's made to allow a developer to refer to a field+  -- with a custom name.+  -- The another argument is 'StoreFieldOps'.+  TargetField+    :: ( InstrGetFieldC dt fname+       , InstrSetFieldC dt fname+       , GetFieldType dt fname ~ targetFType+       , AccessFieldC dt fname+       )+    => Label fname+    -> StoreFieldOps dt targetFName targetFType+    -> FieldLens dt targetFName targetFType++  -- Deeper field of @dt@.+  -- It takes a label with name of direct field and+  -- 'HasField' with deeper field as source and+  -- with the same target field,+  -- so it's how this datatype is alike list of fields.+  -- The last argument is Lorentz operations to get and set target field.+  DeeperField+    :: ( AccessFieldC dt fname+       , InstrSetFieldC dt fname+       , HasField (GetFieldType dt fname) targetFName targetFType+       )+    => Label fname+    -> StoreFieldOps dt targetFName targetFType+    -> FieldLens dt targetFName targetFType++-- | Access to 'StoreFieldOps'+flSFO :: FieldLens dt fname ftype -> StoreFieldOps dt fname ftype+flSFO (TargetField _ sfo) = sfo+flSFO (DeeperField _ sfo) = sfo++-- | Class like 'StoreHasField' type class but holding a lens to a field.+class (KnownValue ftype, KnownValue dt) => HasField dt fname ftype | dt fname -> ftype  where+  fieldLens :: FieldLens dt fname ftype++-- | Build a lens to a direct field of an object.+fieldLensADT+  :: forall dt targetFName targetFType fname  .+  ( InstrGetFieldC dt fname+  , InstrSetFieldC dt fname+  , GetFieldType dt fname ~ targetFType+  , AccessFieldC dt fname+  )+ => Label fname -> FieldLens dt targetFName targetFType+fieldLensADT lb =+  let sfo = storeFieldOpsADT @dt @fname in+  TargetField lb $ storeFieldOpsReferTo (fieldNameFromLabel lb) sfo++-- | Build a lens to deeper field of an object.+fieldLensDeeper+  :: forall dt targetName targetType fname .+  ( AccessFieldC dt fname+  , L.HasFieldOfType dt fname (GetFieldType dt fname)+  , HasDupableGetters (GetFieldType dt fname)+  , HasField (GetFieldType dt fname) targetName targetType+  )+  => Label fname+  -> FieldLens dt targetName targetType+fieldLensDeeper lb =+  DeeperField lb $+    composeStoreFieldOps (fieldNameFromLabel lb) (storeFieldOpsADT @dt) (flSFO fieldLens)++-- | Default instance for datatype and its direct field name.+-- It will be useful unless you want to refer to a field using a custom name.+instance {-# OVERLAPPABLE #-}+         ( InstrSetFieldC dt fname+         , InstrGetFieldC dt fname+         , GetFieldType dt fname ~ ftype+         , AccessFieldC dt fname+         , KnownSymbol fname+         , KnownValue ftype, KnownValue dt+         )+         => HasField dt fname ftype where+  fieldLens = TargetField (Label @fname) storeFieldOpsADT

@@ -0,0 +1,211 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# LANGUAGE QuantifiedConstraints #-}++module Indigo.Common.Object+  ( IndigoObjectF (..)+  , NamedFieldObj (..)+  , TypedFieldObj (..)+  , FieldTypes+  , Object+  , SomeObject (..)+  , namedToTypedRec+  , typedToNamedRec+  , namedToTypedFieldObj+  , typedToNamedFieldObj++  , IsObject+  , complexObjectDict+  , ComplexObjectC+  , castFieldConstructors+  , withInstrDeconstructC+  ) where++import Data.Constraint (Dict(..))+import Data.Vinyl (RMap, RecordToList)+import Data.Vinyl.TypeLevel (AllConstrained)+import GHC.Generics qualified as G++import Indigo.Backend.Prelude+import Indigo.Common.Var (RefId)+import Indigo.Lorentz+import Morley.Michelson.Typed (IsPrimitiveValue, ToTs)+import Morley.Michelson.Typed.Haskell.Instr.Product+  (CastFieldConstructors(..), ConstructorFieldNames, FieldConstructor(..), GetFieldType,+  InstrDeconstructC)+import Morley.Util.Type (KList(..), KnownList(..), type (++))++----------------------------------------------------------------------------+-- IndigoObjectF+----------------------------------------------------------------------------++-- | A object that can be either+-- stored in the single stack cell or split into fields.+-- Fields are identified by their names.+--+-- @f@ is a functor to be applied to each of field names.+data IndigoObjectF f a where+  -- | Value stored on the stack, it might be+  -- either complex product type, like @(a, b)@, Storage, etc,+  -- or sum type like 'Either', or primitive like 'Int', 'Operation', etc.+  Cell :: KnownValue a => RefId -> IndigoObjectF f a+  -- | Decomposed product type, which is NOT stored+  -- as one cell on the stack.+  Decomposed :: ComplexObjectC a => Rec f (ConstructorFieldNames a) -> IndigoObjectF f a++-- | Auxiliary type family to convert list of field names+-- to list of field types+type family MapGFT a rs where+  MapGFT _ '[] = '[]+  MapGFT a (name ': xs) = GetFieldType a name ': MapGFT a xs++-- | Convert a list of fields from name-based list to type-based one+namedToTypedRec+  :: forall a f g .+    (forall name . f name -> g (GetFieldType a name))+  -> Rec f (ConstructorFieldNames a)+  -> Rec g (FieldTypes a)+namedToTypedRec fun = namedToTypedRecImpl+  where+    namedToTypedRecImpl :: Rec f rs -> Rec g (MapGFT a rs)+    namedToTypedRecImpl RNil = RNil+    namedToTypedRecImpl (v :& xs) = fun v :& namedToTypedRecImpl xs++-- | Convert a list of fields from type-based list to named-based one+typedToNamedRec :: forall a f g . KnownList (ConstructorFieldNames a)+  => (forall name . f (GetFieldType a name) -> g name)+  -> Rec f (FieldTypes a)+  -> Rec g (ConstructorFieldNames a)+typedToNamedRec fun = typedToNamedRecImpl+  where+    typedToNamedRecImpl :: forall rs . KnownList rs => Rec f (MapGFT a rs) -> Rec g rs+    typedToNamedRecImpl re = case (klist @rs, re) of+      (KNil, RNil)  -> RNil+      (KCons (_ :: Proxy nm) (_ :: Proxy rs'), v :& vs) -> fun v :& typedToNamedRecImpl vs++castFieldConstructors+  :: forall a st . CastFieldConstructors (FieldTypes a) (ConstructorFieldTypes a)+  => Rec (FieldConstructor st) (FieldTypes a) -> Rec (FieldConstructor st) (ConstructorFieldTypes a)+castFieldConstructors = castFieldConstructorsImpl++-- | Auxiliary datatype to define a Objiable.+-- Keeps field name as type param+data NamedFieldObj a name where+  NamedFieldObj+    :: IsObject (GetFieldType a name)+    => { unFieldObj :: Object (GetFieldType a name)+       }+    -> NamedFieldObj a name++type Object a = IndigoObjectF (NamedFieldObj a) a++data SomeObject where+  SomeObject :: IsObject a => Object a -> SomeObject++-- | Like 'NamedFieldObj', but this one doesn't keep name of a field+data TypedFieldObj a where+  TypedFieldObj :: IsObject a => Object a -> TypedFieldObj a++namedToTypedFieldObj :: forall a name . NamedFieldObj a name -> TypedFieldObj (GetFieldType a name)+namedToTypedFieldObj (NamedFieldObj f) = TypedFieldObj f++typedToNamedFieldObj :: forall a name . TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name+typedToNamedFieldObj (TypedFieldObj f) = NamedFieldObj f++----------------------------------------------------------------------------+-- IsObject type class+----------------------------------------------------------------------------++class IsObject' (TypeDecision a) a => IsObject a+instance IsObject' (TypeDecision a) a => IsObject a++type FieldTypes a = MapGFT a (ConstructorFieldNames a)++-- | Simply a synonym for an unwieldy constraint.+type InstrDeconstructCClassConstraint a st =+  ( InstrDeconstructC a (ToTs st)+  , ToTs (ConstructorFieldTypes a) ++ (ToTs st) ~ ToTs (ConstructorFieldTypes a ++ st)+  )++-- | We need this because 'InstrDeconstructC' is a constraint synonym, and parts+-- of it aren't exported from morley. Hence can't declare a quantified+-- constraint over it. And we really don't want to carry input stack everywhere+-- explicitly, hence why we want a quantified constraint.+class InstrDeconstructCClassConstraint a st => InstrDeconstructCClass (a :: Type) (st :: [Type])+instance InstrDeconstructCClassConstraint a st => InstrDeconstructCClass a st++-- | Simply a synonym for a quantified constraint, because we can't use a+-- quantified constraint in a synonym tuple.+class (forall st. InstrDeconstructCClass a st) => InstrDeconstructCGeneral a+instance (forall st. InstrDeconstructCClass a st) => InstrDeconstructCGeneral a++-- | Produce evidence of 'InstrDeconstructC' for a concrete input stack, and run+-- a computation with it.+withInstrDeconstructC+  :: forall a st r. InstrDeconstructCGeneral a+  => (InstrDeconstructCClass a st => r) -> r+withInstrDeconstructC f = f++type ToDeconstructC a =+  ( InstrDeconstructCGeneral a+  , KnownList (FieldTypes a)+  , AllConstrained KnownValue (FieldTypes a)+  , FieldTypes a ~ ConstructorFieldTypes a+  )++type ToConstructC a =+  ( KnownValue a+  , InstrConstructC a+  , RMap (ConstructorFieldNames a)+  , RMap (ConstructorFieldTypes a)+  , RMap (FieldTypes a)+  , KnownList (ConstructorFieldNames a)+  , CastFieldConstructors (FieldTypes a) (ConstructorFieldTypes a)+  )++type ComplexObjectC a =+  ( ToDeconstructC a+  , ToConstructC a+  , AllConstrained IsObject (FieldTypes a)+  , RecordToList (FieldTypes a) -- for Buildable+  )++-- | Type class instantiated for all possible Indigo types+class KnownValue a => IsObject' (decision :: Decision) a where+  complexObjectDict' :: Maybe (Dict (ComplexObjectC a))++instance KnownValue a => IsObject' 'PrimitiveD a where+  complexObjectDict' = Nothing++instance KnownValue a => IsObject' 'SumTypeD a where+  complexObjectDict' = Nothing++instance ComplexObjectC a => IsObject' 'ProductTypeD a where+  complexObjectDict' = Just Dict++complexObjectDict :: forall a . IsObject a => Maybe (Dict (ComplexObjectC a))+complexObjectDict = complexObjectDict' @(TypeDecision a) @a++-- | Decide whether type is either primitive or ADT+type TypeDecision a = Decide (IsPrimitiveValue a) (IsSumType (G.Rep a))++data Decision+  = PrimitiveD+  | SumTypeD+  | ProductTypeD++type family Decide flagPrimitive flagSumType where+  Decide 'True _ = 'PrimitiveD+  Decide 'False 'True = 'SumTypeD+  Decide 'False 'False = 'ProductTypeD++type family IsSumType x where+  IsSumType (G.D1 _ x) = IsSumType x+  IsSumType (G.C1 _ x) = IsSumType x+  IsSumType (G.M1 _ _ x) = IsSumType x+  IsSumType (_ G.:*: _) = 'False+  IsSumType (G.Rec0 _) = 'False+  IsSumType G.V1 = 'False+  IsSumType G.U1 = 'False+  IsSumType (_ G.:+: _) = 'True

@@ -0,0 +1,55 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 'SomeIndigoState' existential and utilities to work with it.+module Indigo.Common.SIS+  ( SomeIndigoState (..)+  , SomeGenCode (..)+  , toSIS+  , runSIS+  , thenSIS+  , overSIS+  ) where++import Indigo.Prelude++import Indigo.Common.State++-- | 'GenCode' with hidden output stack+data SomeGenCode inp where+  SomeGenCode :: GenCode inp out -> SomeGenCode inp++-- | 'IndigoState' with hidden output stack,+-- necessary to generate typed Lorentz code from untyped Indigo frontend.+newtype SomeIndigoState inp = SomeIndigoState+  { unSIS :: MetaData inp -> SomeGenCode inp+  }++-- | To run 'SomeIndigoState' you need to pass an handler of 'GenCode' with any+-- output stack and initial 'MetaData'.+runSIS :: SomeIndigoState inp -> MetaData inp -> (forall out . GenCode inp out -> r) -> r+runSIS (SomeIndigoState act) md f = case act md of+  SomeGenCode gc -> f gc++-- | Convert 'IndigoState' to 'SomeIndigoState'+toSIS :: IndigoState inp out -> SomeIndigoState inp+toSIS is = SomeIndigoState $ \md -> SomeGenCode $ runIndigoState is md++-- | Similar to a @>>@ for 'SomeIndigoState'.+thenSIS :: SomeIndigoState inp -> (forall out . SomeIndigoState out) -> SomeIndigoState inp+thenSIS m f = SomeIndigoState $ \md ->+  case unSIS m md of+    (SomeGenCode (GenCode st1 cd1 cl1 :: GenCode inp out)) ->+      case unSIS (f @out) (replStkMd md st1) of+        SomeGenCode (GenCode st2 cd2 cl2) ->+          SomeGenCode (GenCode st2 (cd1 ## cd2) (cl2 ## cl1))++-- | Modify the 'GenCode' inside a 'SomeIndigoState' by passing an handler of+-- 'GenCode' that returns a 'SomeGenCode'.+-- Useful in some cases to "wrap" or update and exising 'SomeGenCode'.+overSIS+  :: (forall out. GenCode inp out -> SomeGenCode inp)+  -> SomeIndigoState inp+  -> SomeIndigoState inp+overSIS f si = SomeIndigoState $ \md -> runSIS si md f

@@ -0,0 +1,247 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# LANGUAGE InstanceSigs #-}++{- |+This module contains the core of Indigo language:+'IndigoState', a datatype that represents its state.+It also includes some convenient functions to work with it,+to provide rebindable syntax.++'IndigoState' implements the functionality of a symbolic interpreter.+During its execution Lorentz code is being generated.++Functionally, it's the same as having Lorentz instruction that can access and+modify a 'StackVars', referring to values on the stack with a 'RefId'.+-}++module Indigo.Common.State+  ( -- * Indigo State+    IndigoState (..)+  , usingIndigoState+  , (>>)+  , (<$>)+  , iput+  , nopState+  , assignTopVar+  , withObject+  , withObjectState+  , withStackVars++  , DecomposedObjects+  , GenCodeHooks (..)+  , emptyGenCodeHooks+  , MetaData (..)+  , stmtHook+  , stmtHookState+  , auxiliaryHook+  , auxiliaryHookState+  , exprHook+  , exprHookState+  , replStkMd+  , alterStkMd+  , pushRefMd+  , pushNoRefMd+  , popNoRefMd++  , GenCode (..)+  , cleanGenCode++  , (##)+  ) where++import Data.Map qualified as M+import Data.Typeable (eqT, (:~:)(..))+import Fmt (pretty)++import Indigo.Backend.Prelude+import Indigo.Common.Object+import Indigo.Common.Var+import Indigo.Lorentz+import Lorentz.Instr qualified as L+import Morley.Michelson.Typed qualified as M+import Morley.Util.Peano++----------------------------------------------------------------------------+-- Indigo State+----------------------------------------------------------------------------++-- | IndigoState data type.+--+-- It takes as input a 'StackVars' (for the initial state) and returns a+-- 'GenCode' (for the resulting state and the generated Lorentz code).+--+-- IndigoState has to be used to write backend typed Lorentz code+-- from the corresponding frontend constructions.+--+-- It has no return type, IndigoState instruction may take one or more+-- "return variables", that they assign to values produced during their execution.+newtype IndigoState inp out = IndigoState {+    runIndigoState :: MetaData inp -> GenCode inp out+  }++-- | Inverse of 'runIndigoState' for utility.+usingIndigoState :: MetaData inp -> IndigoState inp out -> GenCode inp out+usingIndigoState md act = runIndigoState act md++-- | Then for rebindable syntax.+(>>) :: IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1+(>>) a b = IndigoState $ \md ->+  let GenCode st1 cd1 cl1 = runIndigoState a md in+  let GenCode st2 cd2 cl2 = runIndigoState b (replStkMd md st1) in+  GenCode st2 (cd1 ## cd2) (cl2 ## cl1)++-- | Put new 'GenCode'.+iput :: GenCode inp out -> IndigoState inp out+iput gc = IndigoState $ \_ -> gc++-- | The simplest 'IndigoState', it does not modify the stack, nor the produced+-- code.+nopState :: IndigoState inp inp+nopState = IndigoState $ \md -> GenCode (mdStack md) L.nop L.nop++-- | Assigns a variable to reference the element on top of the stack.+assignTopVar :: KnownValue x => Var x -> IndigoState (x : inp) (x : inp)+assignTopVar var = IndigoState $ \md ->+  GenCode (assignVarAt var (mdStack md) SZ) L.nop L.nop++withObject+  :: forall a r .  KnownValue a+  => DecomposedObjects+  -> Var a+  -> (Object a -> r)+  -> r+withObject objs (Var refId) f = case M.lookup refId objs of+  Nothing -> f (Cell refId)+  Just so -> case so of+    SomeObject (obj :: Object a1) -> case eqT @a @a1 of+      Just Refl -> f obj+      Nothing ->+        error $ "unexpectedly SomeObject with by reference #" <> pretty refId <> " has different type"++withObjectState+  :: forall a inp out . KnownValue a+  => Var a+  -> (Object a -> IndigoState inp out)+  -> IndigoState inp out+withObjectState v f = IndigoState $ \md -> usingIndigoState md (withObject (mdObjects md) v f)++-- | Utility function to create 'IndigoState' that need access to the current 'StackVars'.+withStackVars :: (StackVars inp -> IndigoState inp out) -> IndigoState inp out+withStackVars fIs = IndigoState $ \md -> usingIndigoState md (fIs $ mdStack md)++----------------------------------------------------------------------------+-- MetaData primitives+----------------------------------------------------------------------------++type DecomposedObjects = Map RefId SomeObject++data MetaData inp = MetaData+  { mdStack   :: StackVars inp+  , mdObjects :: DecomposedObjects+  , mdHooks   :: GenCodeHooks+  }++data GenCodeHooks = GenCodeHooks+  { gchStmtHook      :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)+  , gchAuxiliaryHook :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)+  , gchExprHook      :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)+  -- pva701: dunno whether this level of verbosity is needed+  --, csSubExpr    :: forall a inp out . Expr a -> (inp :-> out) -> (inp :-> out)+  }++instance Semigroup GenCodeHooks where+  GenCodeHooks a b c <> GenCodeHooks a1 b1 c1 = GenCodeHooks+    { gchStmtHook = \t cd -> a1 t (a t cd)+    , gchAuxiliaryHook = \t cd -> b1 t (b t cd)+    , gchExprHook = \t cd -> c1 t (c t cd)+    }++instance Monoid GenCodeHooks where+  mempty = emptyGenCodeHooks++emptyGenCodeHooks :: GenCodeHooks+emptyGenCodeHooks = GenCodeHooks (const id) (const id) (const id)++stmtHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)+stmtHook MetaData{..} tx cd = (gchStmtHook mdHooks) tx cd++stmtHookState :: Text -> IndigoState inp out -> IndigoState inp out+stmtHookState tx cd = IndigoState $ \md ->+  let GenCode st c cl = usingIndigoState md cd in+  GenCode st (stmtHook md tx c) cl++auxiliaryHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)+auxiliaryHook MetaData{..} tx cd = (gchAuxiliaryHook mdHooks) tx cd++auxiliaryHookState :: Text -> IndigoState inp out -> IndigoState inp out+auxiliaryHookState tx cd = IndigoState $ \md ->+  let GenCode st c cl = usingIndigoState md cd in+  GenCode st (auxiliaryHook md tx c) cl++exprHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)+exprHook MetaData{..} exTx cd = (gchExprHook mdHooks) exTx cd++exprHookState :: Text -> IndigoState inp out -> IndigoState inp out+exprHookState tx cd = IndigoState $ \md ->+  let GenCode st c cl = usingIndigoState md cd in+  GenCode st (exprHook md tx c) cl+++replStkMd :: MetaData inp -> StackVars inp1 -> MetaData inp1+replStkMd md = alterStkMd md . const++alterStkMd :: MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1+alterStkMd (MetaData stk objs cm) f = MetaData (f stk) objs cm++-- | 'pushRef' version for 'MetaData'+pushRefMd :: KnownValue a => Var a -> MetaData inp -> MetaData (a : inp)+pushRefMd var md = alterStkMd md (pushRef var)++-- | 'pushNoRef' version for 'MetaData'+pushNoRefMd :: KnownValue a => MetaData inp -> MetaData (a : inp)+pushNoRefMd md = alterStkMd md pushNoRef++-- | 'popNoRef' version for 'MetaData'+popNoRefMd :: MetaData (a : inp) -> MetaData inp+popNoRefMd md = alterStkMd md popNoRef++----------------------------------------------------------------------------+-- Code generation primitives+----------------------------------------------------------------------------++-- | Resulting state of IndigoM.+data GenCode inp out = GenCode+  { gcStack :: ~(StackVars out)+  -- ^ Stack of the symbolic interpreter.+  , gcCode  :: inp :-> out+  -- ^ Generated Lorentz code.+  , gcClear :: out :-> inp+  -- ^ Clearing Lorentz code.+  }++-- | Produces the generated Lorentz code that cleans after itself, leaving the+-- same stack as the input one+cleanGenCode :: GenCode inp out -> inp :-> inp+cleanGenCode GenCode {..} = gcCode ## gcClear++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- | Version of '#' which performs some optimizations immediately.+--+-- In particular, this avoids glueing @Nop@s.+(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)+l ## r =+  -- We are very verbose about cases to avoid+  -- significant compilation time increase+  case l of+    I M.Nop -> case r of+      I x -> I x+      _   -> l # r+    I x -> case r of+      I M.Nop -> I x+      _       -> l # r+    _ -> l # r

@@ -0,0 +1,157 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Datatype representing Indigo variables and utilities for working with+-- them.+module Indigo.Common.Var+  ( -- * Variables+    Var (..)+  , RefId+  , StackVars (..)+  , StackVars'+  , StkEl (..)++  -- * Stack operations+  , emptyStack+  , assignVarAt+  , pushRef+  , pushNoRef+  , popNoRef++  -- * Operations/Storage variables+  , Ops+  , HasSideEffects+  , operationsVar+  , HasStorage+  , storageVar+  ) where++import Data.Kind qualified as Kind+import Data.Reflection (Given(..))+import Data.Singletons (Sing)+import Data.Type.Equality (TestEquality(..))+import Data.Typeable (eqT)+import Fmt (Buildable(..), pretty)+import Morley.Michelson.Typed.Haskell.Value+import Morley.Util.Peano++import Indigo.Backend.Prelude+import Indigo.Lorentz++----------------------------------------------------------------------------+-- Stack and variable definition+----------------------------------------------------------------------------++-- | Reference id to a stack cell+newtype RefId = RefId Word+  deriving stock (Show, Generic)+  deriving newtype (Eq, Ord, Real, Num, Integral, Enum, Bounded)++instance Buildable RefId where+  build (RefId r) = "#ref" <> pretty r++-- | Stack element of the symbolic interpreter.+--+-- It holds either a reference index that refers to this element+-- or just 'NoRef', indicating that there are no references+-- to this element.+data StkEl a where+  NoRef :: (KnownValue a, KnownIsoT a) => StkEl a+  Ref :: (KnownValue a, KnownIsoT a) => RefId -> StkEl a++instance TestEquality StkEl where+  testEquality NoRef NoRef = eqT+  testEquality (Ref _) (Ref _) = eqT+  testEquality (Ref _) NoRef = eqT+  testEquality NoRef (Ref _) = eqT++type StackVars' stk = Rec StkEl stk++-- | Stack of the symbolic interpreter.+data StackVars (stk :: [Kind.Type]) where+  StkElements  :: Rec StkEl stk -> StackVars stk+  FailureStack :: StackVars stk++-- | A variable referring to an element in the stack.+data Var a = Var RefId+  deriving stock (Generic, Show)++instance Buildable (Var a) where+  build (Var (RefId r)) = "$var" <> pretty r++----------------------------------------------------------------------------+-- Stack operations+----------------------------------------------------------------------------++emptyStack :: StackVars '[]+emptyStack = StkElements RNil++instance Default (StackVars '[]) where+  def = emptyStack++instance (KnownValue x, Default (StackVars xs)) => Default (StackVars (x ': xs)) where+  def = case def of+    FailureStack -> error "impossible happened"+    StkElements rc -> StkElements $ NoRef :& rc++-- | Given a 'StackVars' and a @Peano@ singleton for a depth, it puts a new 'Var'+-- at that depth (0-indexed) and returns it with the updated 'StackVars'.+--+-- If there is a 'Var' there already it is used and the 'StackVars' not changed.+assignVarAt+  :: (KnownValue a, a ~ At n inp, RequireLongerThan inp n)+  => Var a+  -> StackVars inp+  -> Sing n+  -> StackVars inp+assignVarAt _ FailureStack = const $ error "You try to assing var against failure stack"+assignVarAt var@(Var varRef) st@(StkElements (top :& xs)) = \case+  SS n -> appendToStack top $ assignVarAt var (StkElements xs) n+  SZ -> case top of+    Ref mdRef | mdRef == varRef -> st+    Ref _ -> error "Tried to assign a Var to an already referenced value"+    NoRef -> StkElements $ Ref varRef :& xs+  where+    appendToStack :: StkEl x -> StackVars inp -> StackVars (x ': inp)+    appendToStack _ FailureStack = error "append to failure stack"+    appendToStack v (StkElements s) = StkElements (v :& s)++-- | Push a new stack element with a reference to it, given the variable.+pushRef :: KnownValue a => Var a -> StackVars inp -> StackVars (a : inp)+pushRef _ FailureStack = error "You try to push ref to failure stack"+pushRef (Var ref) (StkElements xs) = StkElements $ Ref ref :& xs++-- | Push a new stack element without a reference to it.+pushNoRef :: KnownValue a => StackVars inp -> StackVars (a : inp)+pushNoRef FailureStack = error "You try to push no-ref to failure stack"+pushNoRef (StkElements xs) = StkElements $ NoRef :& xs++-- | Remove the top element of the stack.+-- It's supposed that no variable refers to this element.+popNoRef :: StackVars (a : inp) -> StackVars inp+popNoRef FailureStack = error "You try to pop from failure stack"+popNoRef (StkElements (NoRef :& xs)) = StkElements xs+popNoRef (StkElements (Ref refId :& _)) =+  error $ "You try to pop stack element, which is referenced by some variable #" <> pretty refId++----------------------------------------------------------------------------+-- Operations/Storage variables+----------------------------------------------------------------------------++type Ops = [Operation]++-- | Allows to get a variable with operations+type HasSideEffects = Given (Var Ops)++-- | Return a variable which refers to a stack cell with operations+operationsVar :: HasSideEffects => Var Ops+operationsVar = given++-- This storage machinery is here to avoid cyclic deps++-- | Allows to get a variable with storage+type HasStorage st = (Given (Var st), KnownValue st)++-- | Return a variable which refers to a stack cell with storage+storageVar :: HasStorage st => Var st+storageVar = given

@@ -14,9 +14,14 @@   , compileIndigoContract   ) where -import qualified Data.Map as M+import Data.Map qualified as M import Prelude +import Indigo.Backend.Expr.Decompose (deepDecomposeCompose)+import Indigo.Common.Object (IsObject, SomeObject(SomeObject))+import Indigo.Common.SIS (SomeGenCode(SomeGenCode))+import Indigo.Common.State (GenCode(GenCode), MetaData(MetaData))+import Indigo.Common.Var import Indigo.Compilation.Field import Indigo.Compilation.Hooks   (CommentHooks(..), CommentSettings(..), CommentsVerbosity(..), defaultCommentSettings,@@ -25,10 +30,8 @@ import Indigo.Compilation.Params import Indigo.Compilation.Sequential import Indigo.Frontend.Program (IndigoContract)-import Indigo.Internal hiding (SetField, (<>), (==), (>>)) import Indigo.Lorentz-import qualified Lorentz.Instr as L-import qualified Lorentz.Macro as L+import Lorentz.Instr qualified as L  -- | Compile Indigo code to Lorentz. --@@ -76,7 +79,7 @@   => CommentSettings   -> IndigoContract param st   -> ContractCode param st-compileIndigoContractFull (settingsToHooks -> CommentHooks{..}) code =+compileIndigoContractFull (settingsToHooks -> CommentHooks{..}) code = mkContractCode $   prepare $ compileIndigoImpl @3 @'[param, st, Ops] chFrontendHooks (contractToIndigoWithParams code) $ \(block, nextRef) ->     \case       (StkElements (Ref parRef :& Ref stRef :& opsStack))  ->

@@ -8,8 +8,8 @@  import Indigo.Backend.Prelude +import Indigo.Common.Var (RefId) import Indigo.Compilation.Sequential-import Indigo.Internal.Var (RefId)  optimizeFields :: (Block, RefId) -> (Block, RefId) optimizeFields = id -- TODO #279

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE NoRebindableSyntax #-} @@ -16,13 +15,13 @@ import Prelude  import GHC.Stack.Types (SrcLoc(..))+import Indigo.Common.State import Indigo.Compilation.Sequential   (InstrCollector(..), Instruction(..), SequentialHooks(..), stmtHookL)-import Indigo.Internal.State import Indigo.Lorentz-import qualified Lorentz.Instr as L-import qualified Michelson.Typed.Convert as M-import qualified Michelson.Typed.Instr as M+import Lorentz.Ext qualified as L+import Morley.Michelson.Typed.Convert qualified as M+import Morley.Michelson.Typed.Instr qualified as M  --------------------------------------------- --- Comments settings

@@ -8,11 +8,11 @@  import Prelude -import qualified Data.Map as M+import Data.Map qualified as M  import Indigo.Backend as B+import Indigo.Common.Var import Indigo.Compilation.Sequential-import Indigo.Internal.Var  -- | Collects named lambdas that are used more than once and separates them into -- a lambda creation and multiple lambda executions.@@ -110,6 +110,7 @@       CreateContract varAddr ctrc exk exm exs -> CreateContract varAddr ctrc exk exm exs       SelfCalling proxy varCR ep -> SelfCalling proxy varCR ep       ContractCalling varMcr pCp epRef exAddr -> ContractCalling varMcr pCp epRef exAddr+      Emit tag ex -> Emit tag ex        Fail failure -> Fail failure       FailOver failure ex -> FailOver failure ex@@ -172,6 +173,7 @@       CreateContract {}  -> return ()       SelfCalling {}     -> return ()       ContractCalling {} -> return ()+      Emit {}            -> return ()       Fail {}            -> return ()       FailOver {}        -> return () 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Indigo.Compilation.Params   ( IndigoWithParams@@ -13,10 +12,11 @@ import Data.Singletons (Sing, SingI(..))  import Indigo.Backend.Prelude-import Indigo.Frontend.Program (IndigoM, IndigoContract)-import Indigo.Internal.Var+import Indigo.Common.Var+import Indigo.Frontend.Program (IndigoContract, IndigoM) import Indigo.Lorentz-import Util.Peano+import Morley.Michelson.Typed.Contract (giveNotInView)+import Morley.Util.Peano  -- | Type of a function with @n@ 'Var' arguments and @IndigoM a@ result. --@@ -73,4 +73,4 @@   => IndigoContract param st   -> IndigoWithParams 3 '[param, st, Ops] () contractToIndigoWithParams code = \varOps varSt varParam ->-  (give varOps $ give varSt code) varParam+  (give varOps $ giveNotInView $ give varSt code) varParam

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | 'Instruction' datatype and its compilations. --@@ -38,323 +37,21 @@  import Data.Vinyl.Core (RMap(..)) -import Lens.Micro.TH (makeLensesFor)-import Lorentz.Entrypoints.Helpers (RequireSumType)-import qualified Lorentz.Run as L (Contract)-import Michelson.Typed.Haskell.Instr.Sum (CaseClauseParam(..), CtorField(..))-import Util.TypeLits (AppendSymbol)- import Indigo.Backend-import Indigo.Frontend.Program-import qualified Indigo.Frontend.Statement as S-import Indigo.Internal (Expr, HasField)-import Indigo.Internal.Object (IsObject)-import Indigo.Internal.SIS-import Indigo.Internal.State hiding ((>>))-import qualified Indigo.Internal.State as St-import Indigo.Internal.Var-import Indigo.Lorentz-import qualified Michelson.Typed as MT---- | Simple synonym for a list of 'Instruction'-type Block = [Instruction]---- | Data type representing an instruction.------ Differently from the frontend this is not used to build a Monad of some kind,--- it is instead based on having as argument the variable to associate with the--- resulting value (if any).------ This is combined in simple lists, named 'Block', and it is intended to be--- easily altered, this is because these are used as the intermediate representation--- between the frontend and the backend, where optimizations can occur.-data Instruction where-  LiftIndigoState :: (forall inp. SomeIndigoState inp) -> Instruction-  Comment :: Text -> Instruction--  AssignVar :: KnownValue x => Var x -> Expr x -> Instruction-  SetVar :: KnownValue x => Var x -> Expr x -> Instruction-  VarModification-    :: (IsObject x, KnownValue y)-    => [y, x] :-> '[x]-    -> Var x-    -> Expr y-    -> Instruction-  SetField-    :: ( HasField store fname ftype-       , IsObject store-       , IsObject ftype-       )-    => Var store -> Label fname -> Expr ftype -> Instruction--  LambdaCall1-    :: LambdaKind st arg ret extra-    -- ^ Kind of lambda (pure, storage modification, fully functional lambda with effects)-    -> String-    -- ^ Name of the lambda-    -> Expr arg-    -- ^ Expression for the lambda argument-    -> Var arg-    -- ^ Variable for the argument value (available to the lambda code block)-    -> Block-    -- ^ Code block for the lambda-    -> ret-    -- ^ Return value(s) of the lambda-    -> RetVars ret-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction--  CreateLambda1-    :: CreateLambda1CGeneric extra arg ret-    => StackVars (arg : extra)-    -- ^ Initial 'StackVars' to be used in the lambda code-    -> Var arg-    -- ^ Variable for the argument value (available to the lambda code block)-    -> Block-    -- ^ Code block for the lambda-    -> ret-    -- ^ Return value(s) of the lambda-    -> Var (Lambda1Generic extra arg ret)-    -- ^ Variable that will be assigned to the resulting lambda-    -> Instruction--  ExecLambda1-    :: LambdaKind st arg ret extra-    -> Proxy ret-    -> Expr arg-    -- ^ Expression for the lambda argument-    -> Var (Lambda1Generic extra arg ret)-    -- ^ Variable of the lambda to be executed-    -> RetVars ret-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction--  Scope-    :: ScopeCodeGen ret-    => Block-    -- ^ Code block to execute inside the scope-    -> ret-    -- ^ Return value(s) of the scoped code block-    -> RetVars ret-    -- ^ Variable that will be assigned to the resulting value(s)-    -> Instruction-  If-    :: IfConstraint a b-    => Expr Bool-    -- ^ Expression for the control flow-    -> Block-    -- ^ Code block for the positive branch-    -> a-    -- ^ Return value(s) of the positive branch-    -> Block-    -- ^ Code block for the negative branch-    -> b-    -- ^ Return value(s) of the negative branch-    -> RetVars a-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction-  IfSome-    :: (IfConstraint a b, KnownValue x)-    => Expr (Maybe x)-    -- ^ Expression for the control flow-    -> Var x-    -- ^ Variable for the 'Just' value (available to the next code block)-    -> Block-    -- ^ Code block for the 'Just' branch-    -> a-    -- ^ Return value(s) of the 'Just' branch-    -> Block-    -- ^ Code block for the 'Nothing' branch-    -> b-    -- ^ Return value(s) of the 'Nothing' branch-    -> RetVars a-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction-  IfRight-    :: (IfConstraint a b, KnownValue r, KnownValue l)-    => Expr (Either l r)-    -- ^ Expression for the control flow-    -> Var r-    -- ^ Variable for the 'Right' value (available to the next code block)-    -> Block-    -- ^ Code block for the 'Right' branch-    -> a-    -- ^ Return value(s) of the 'Right' branch-    -> Var l-    -- ^ Variable for the 'Left' value (available to the next code block)-    -> Block-    -- ^ Code block for the 'Left' branch-    -> b-    -- ^ Return value(s) of the 'Left' branch-    -> RetVars a-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction-  IfCons-    :: (IfConstraint a b, KnownValue x)-    => Expr (List x)-    -- ^ Expression for the control flow-    -> Var x-    -- ^ Variable for the "head" value (available to the next code block)-    -> Var (List x)-    -- ^ Variable for the "tail" value (available to the next code block)-    -> Block-    -- ^ Code block for the non-empty list branch-    -> a-    -- ^ Return value(s) of the non-empty list branch-    -> Block-    -- ^ Code block for the empty list branch-    -> b-    -- ^ Return value(s) of the empty list branch-    -> RetVars a-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction--  Case-    :: CaseCommon dt ret clauses-    => Expr dt-    -> clauses-    -> RetVars ret-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction-  EntryCase-    :: ( CaseCommon dt ret clauses-       , DocumentEntrypoints entryPointKind dt-       )-    => Proxy entryPointKind-    -> Expr dt-    -> clauses-    -> RetVars ret-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction-  EntryCaseSimple-    :: ( CaseCommon dt ret clauses-       , DocumentEntrypoints PlainEntrypointsKind dt-       , NiceParameterFull dt-       , RequireFlatParamEps dt-       )-    => Expr dt-    -> clauses-    -> RetVars ret-    -- ^ Variable(s) that will be assigned to the resulting value(s)-    -> Instruction--  While-    :: Expr Bool-    -- ^ Expression for the control flow-    -> Block-    -- ^ Block of code to execute, as long as the expression holds 'True'-    -> Instruction-  WhileLeft-    :: (KnownValue l, KnownValue r)-    => Expr (Either l r)-    -- ^ Expression for the control flow value-    -> Var l-    -- ^ Variable for the 'Left' value (available to the code block)-    -> Block-    -- ^ Code block to execute while the value is 'Left'-    -> Var r-    -- ^ Variable that will be assigned to the resulting value-    -> Instruction-  ForEach-    :: (IterOpHs a, KnownValue (IterOpElHs a))-    => Expr a-    -- ^ Expression for the container to traverse-    -> Var (IterOpElHs a)-    -- ^ Variable for the current item (available to the code block)-    -> Block-    -- ^ Code block to execute over each element of the container-    -> Instruction--  ContractName-    :: Text-    -> Block-    -> Instruction-  DocGroup-    :: forall di. DocItem di-    => (SubDoc -> di)-    -> Block-    -> Instruction-  ContractGeneral-    :: Block-    -> Instruction-  FinalizeParamCallingDoc-    :: (NiceParameterFull cp, RequireSumType cp)-    => Var cp-    -> Block-    -> Expr cp-    -> Instruction--  TransferTokens-    :: (NiceParameter p, HasSideEffects)-    => Expr p-    -> Expr Mutez-    -> Expr (ContractRef p)-    -> Instruction-  SetDelegate-    :: HasSideEffects-    => Expr (Maybe KeyHash)-    -> Instruction--  CreateContract-    :: (HasSideEffects, NiceStorage s, NiceParameterFull p)-    => L.Contract p s-    -> Expr (Maybe KeyHash)-    -> Expr Mutez-    -> Expr s-    -> Var Address-    -- ^ Variable that will be assigned to the resulting 'Address'-    -> Instruction-  SelfCalling-    :: ( NiceParameterFull p-       , KnownValue (GetEntrypointArgCustom p mname)-       )-    => Proxy p-    -> EntrypointRef mname-    -> Var (ContractRef (GetEntrypointArgCustom p mname))-    -- ^ Variable that will be assigned to the resulting 'ContractRef'-    -> Instruction-  ContractCalling-    :: ( HasEntrypointArg cp epRef epArg-       , ToTAddress cp addr-       , ToT addr ~ ToT Address-       , KnownValue epArg-       )-    => Proxy cp-    -> epRef-    -> Expr addr-    -> Var (Maybe (ContractRef epArg))-    -- ^ Variable that will be assigned to the resulting 'ContractRef'-    -> Instruction--  Fail-    :: (forall inp. SomeIndigoState inp)-    -> Instruction-  FailOver-    :: (forall inp. Expr a -> SomeIndigoState inp)-    -> Expr a-    -> Instruction+import Indigo.Common.SIS+import Indigo.Common.State hiding ((>>))+import Indigo.Common.State qualified as St+import Indigo.Common.Var+import Indigo.Compilation.Sequential.Types+import Indigo.Frontend.Internal.Statement qualified as S+import Indigo.Frontend.Program (IndigoM(..), interpretProgram)+import Indigo.Lorentz hiding (comment)+import Morley.Michelson.Typed qualified as MT  ---------------------------------------------------------------------------- -- Translations ---------------------------------------------------------------------------- --- | Data type internally used to collect 'Instruction's from 'IndigoM'-data InstrCollector = InstrCollector-  { nextRef   :: RefId-  , instrList :: Block-  , seqHooks  :: SequentialHooks-  }--newtype SequentialHooks = SequentialHooks {-    shStmtHook    :: CallStack -> Block -> State InstrCollector ()-  }--instance Semigroup SequentialHooks where-  SequentialHooks s <> SequentialHooks s1 = SequentialHooks (\t -> s t >> s1 t)--instance Monoid SequentialHooks where-  mempty = SequentialHooks (const $ appendNewInstrs . reverse)- -- | Transformation from 'IndigoM' to a 'Block' of 'Instruction's. -- -- Requires the first non-used 'RefId' and returns the next one.@@ -493,6 +190,8 @@     varMcr <- mkNextVar     appendNewInstr $ ContractCalling proxy epRef exAddr varMcr     return varMcr+  S.Emit tag ex ->+    appendNewInstr $ Emit tag ex    S.Fail (_ :: Proxy ret) failure -> do     appendNewInstr $ Fail failure@@ -527,9 +226,6 @@ appendNewInstr :: Instruction -> State InstrCollector () appendNewInstr is = modify $ \iColl -> iColl {instrList = is : instrList iColl} -appendNewInstrs :: Block -> State InstrCollector ()-appendNewInstrs blk = modify $ \iColl -> iColl {instrList = blk ++ instrList iColl}- -- | Creates a new var. This simply advances the ref counter and updates it. mkNextVar :: State InstrCollector (Var a) mkNextVar = do@@ -611,8 +307,10 @@     toSIS $ createContract ctrc exk exm exs varAddr   SelfCalling (Proxy :: Proxy p) ep varCR ->     toSIS $ selfCalling @p ep varCR-  ContractCalling (Proxy :: Proxy cp) epRef exAddr varMcr ->-    toSIS $ contractCalling @cp epRef exAddr varMcr+  ContractCalling (Proxy :: Proxy (cp, vd)) epRef exAddr varMcr ->+    toSIS $ contractCalling @cp @vd epRef exAddr varMcr+  Emit tag ex ->+    toSIS $ emit tag ex    Fail failure -> failure   FailOver failure ex -> failure ex@@ -621,33 +319,6 @@ -- Case machinery ---------------------------------------------------------------------------- --- | Common constraint for case-like 'Instruction's.-type CaseCommon dt ret clauses = CaseCommonF IndigoSeqCaseClause dt ret clauses---- | Analogous datatype as 'IndigoCaseClauseL' and 'IndigoMCaseClauseL'.-data IndigoSeqCaseClause ret (param :: CaseClauseParam) where-  OneFieldIndigoSeqCaseClause-    :: (AppendSymbol "c" ctor ~ name)-    => Label name-    -> CaseBranch x ret-    -> IndigoSeqCaseClause ret ('CaseClauseParam ctor ('OneField x))---- | Representation of a branch of a generic case-like 'Instruction'.-data CaseBranch x ret where-  CaseBranch-    :: ( KnownValue x-       , ScopeCodeGen retBr-       , ret ~ RetExprs retBr-       , RetOutStack ret ~ RetOutStack retBr-       )-    => Var x-    -- ^ Input variable (accessible to the branch's code block)-    -> Block-    -- ^ Code block for this branch-    -> retBr-    -- ^ Return value of this branch-    -> CaseBranch x ret- -- | Convert clauses from their "sequential" representation to the "backend" one. clausesToBackend   :: forall ret dt . RMap dt@@ -696,5 +367,3 @@ mapMClauses f (x :& xs) = case x of   OneFieldIndigoSeqCaseClause _cName (CaseBranch _ block _) ->     f block >> mapMClauses f xs--makeLensesFor [ ("shStmtHook", "stmtHookL")] ''SequentialHooks

@@ -0,0 +1,373 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | 'Instruction' datatype.+module Indigo.Compilation.Sequential.Types+  ( Block+  , Instruction (..)++  , IndigoSeqCaseClause (..)+  , CaseBranch (..)++  -- * Translations+  , SequentialHooks (..)+  , InstrCollector (..)+  , stmtHookL+  ) where++import Prelude++import Lens.Micro.TH (makeLensesFor)+import Lorentz.Entrypoints.Helpers (RequireSumType)+import Lorentz.Run qualified as L (Contract)+import Morley.Michelson.Typed.Haskell.Instr.Sum (CaseClauseParam(..), CtorField(..))+import Morley.Michelson.Untyped.Annotation (FieldAnn)+import Morley.Util.TypeLits (AppendSymbol)++import Indigo.Backend+import Indigo.Common.Expr (Expr)+import Indigo.Common.Field (HasField)+import Indigo.Common.SIS+import Indigo.Common.Var+import Indigo.Lorentz hiding (comment)++-- | Simple synonym for a list of 'Instruction'+type Block = [Instruction]++-- | Data type representing an instruction.+--+-- Differently from the frontend this is not used to build a Monad of some kind,+-- it is instead based on having as argument the variable to associate with the+-- resulting value (if any).+--+-- This is combined in simple lists, named 'Block', and it is intended to be+-- easily altered, this is because these are used as the intermediate representation+-- between the frontend and the backend, where optimizations can occur.+data Instruction where+  LiftIndigoState :: (forall inp. SomeIndigoState inp) -> Instruction+  Comment :: Text -> Instruction++  AssignVar :: KnownValue x => Var x -> Expr x -> Instruction+  SetVar :: KnownValue x => Var x -> Expr x -> Instruction+  VarModification+    :: (IsObject x, KnownValue y)+    => [y, x] :-> '[x]+    -> Var x+    -> Expr y+    -> Instruction+  SetField+    :: ( HasField store fname ftype+       , IsObject store+       , IsObject ftype+       )+    => Var store -> Label fname -> Expr ftype -> Instruction++  LambdaCall1+    :: LambdaKind st arg ret extra+    -- ^ Kind of lambda (pure, storage modification, fully functional lambda with effects)+    -> String+    -- ^ Name of the lambda+    -> Expr arg+    -- ^ Expression for the lambda argument+    -> Var arg+    -- ^ Variable for the argument value (available to the lambda code block)+    -> Block+    -- ^ Code block for the lambda+    -> ret+    -- ^ Return value(s) of the lambda+    -> RetVars ret+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction++  CreateLambda1+    :: CreateLambda1CGeneric extra arg ret+    => StackVars (arg : extra)+    -- ^ Initial 'StackVars' to be used in the lambda code+    -> Var arg+    -- ^ Variable for the argument value (available to the lambda code block)+    -> Block+    -- ^ Code block for the lambda+    -> ret+    -- ^ Return value(s) of the lambda+    -> Var (Lambda1Generic extra arg ret)+    -- ^ Variable that will be assigned to the resulting lambda+    -> Instruction++  ExecLambda1+    :: LambdaKind st arg ret extra+    -> Proxy ret+    -> Expr arg+    -- ^ Expression for the lambda argument+    -> Var (Lambda1Generic extra arg ret)+    -- ^ Variable of the lambda to be executed+    -> RetVars ret+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction++  Scope+    :: ScopeCodeGen ret+    => Block+    -- ^ Code block to execute inside the scope+    -> ret+    -- ^ Return value(s) of the scoped code block+    -> RetVars ret+    -- ^ Variable that will be assigned to the resulting value(s)+    -> Instruction+  If+    :: IfConstraint a b+    => Expr Bool+    -- ^ Expression for the control flow+    -> Block+    -- ^ Code block for the positive branch+    -> a+    -- ^ Return value(s) of the positive branch+    -> Block+    -- ^ Code block for the negative branch+    -> b+    -- ^ Return value(s) of the negative branch+    -> RetVars a+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction+  IfSome+    :: (IfConstraint a b, KnownValue x)+    => Expr (Maybe x)+    -- ^ Expression for the control flow+    -> Var x+    -- ^ Variable for the 'Just' value (available to the next code block)+    -> Block+    -- ^ Code block for the 'Just' branch+    -> a+    -- ^ Return value(s) of the 'Just' branch+    -> Block+    -- ^ Code block for the 'Nothing' branch+    -> b+    -- ^ Return value(s) of the 'Nothing' branch+    -> RetVars a+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction+  IfRight+    :: (IfConstraint a b, KnownValue r, KnownValue l)+    => Expr (Either l r)+    -- ^ Expression for the control flow+    -> Var r+    -- ^ Variable for the 'Right' value (available to the next code block)+    -> Block+    -- ^ Code block for the 'Right' branch+    -> a+    -- ^ Return value(s) of the 'Right' branch+    -> Var l+    -- ^ Variable for the 'Left' value (available to the next code block)+    -> Block+    -- ^ Code block for the 'Left' branch+    -> b+    -- ^ Return value(s) of the 'Left' branch+    -> RetVars a+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction+  IfCons+    :: (IfConstraint a b, KnownValue x)+    => Expr (List x)+    -- ^ Expression for the control flow+    -> Var x+    -- ^ Variable for the "head" value (available to the next code block)+    -> Var (List x)+    -- ^ Variable for the "tail" value (available to the next code block)+    -> Block+    -- ^ Code block for the non-empty list branch+    -> a+    -- ^ Return value(s) of the non-empty list branch+    -> Block+    -- ^ Code block for the empty list branch+    -> b+    -- ^ Return value(s) of the empty list branch+    -> RetVars a+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction++  Case+    :: CaseCommon dt ret clauses+    => Expr dt+    -> clauses+    -> RetVars ret+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction+  EntryCase+    :: ( CaseCommon dt ret clauses+       , DocumentEntrypoints entryPointKind dt+       )+    => Proxy entryPointKind+    -> Expr dt+    -> clauses+    -> RetVars ret+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction+  EntryCaseSimple+    :: ( CaseCommon dt ret clauses+       , DocumentEntrypoints PlainEntrypointsKind dt+       , NiceParameterFull dt+       , RequireFlatParamEps dt+       )+    => Expr dt+    -> clauses+    -> RetVars ret+    -- ^ Variable(s) that will be assigned to the resulting value(s)+    -> Instruction++  While+    :: Expr Bool+    -- ^ Expression for the control flow+    -> Block+    -- ^ Block of code to execute, as long as the expression holds 'True'+    -> Instruction+  WhileLeft+    :: (KnownValue l, KnownValue r)+    => Expr (Either l r)+    -- ^ Expression for the control flow value+    -> Var l+    -- ^ Variable for the 'Left' value (available to the code block)+    -> Block+    -- ^ Code block to execute while the value is 'Left'+    -> Var r+    -- ^ Variable that will be assigned to the resulting value+    -> Instruction+  ForEach+    :: (IterOpHs a, KnownValue (IterOpElHs a))+    => Expr a+    -- ^ Expression for the container to traverse+    -> Var (IterOpElHs a)+    -- ^ Variable for the current item (available to the code block)+    -> Block+    -- ^ Code block to execute over each element of the container+    -> Instruction++  ContractName+    :: Text+    -> Block+    -> Instruction+  DocGroup+    :: forall di. DocItem di+    => (SubDoc -> di)+    -> Block+    -> Instruction+  ContractGeneral+    :: Block+    -> Instruction+  FinalizeParamCallingDoc+    :: (NiceParameterFull cp, RequireSumType cp)+    => Var cp+    -> Block+    -> Expr cp+    -> Instruction++  TransferTokens+    :: (NiceParameter p, HasSideEffects, IsNotInView)+    => Expr p+    -> Expr Mutez+    -> Expr (ContractRef p)+    -> Instruction+  SetDelegate+    :: (HasSideEffects, IsNotInView)+    => Expr (Maybe KeyHash)+    -> Instruction++  CreateContract+    :: ( HasSideEffects, NiceStorage s, NiceParameterFull p+       , NiceViewsDescriptor vd, Typeable vd, IsNotInView+       )+    => L.Contract p s vd+    -> Expr (Maybe KeyHash)+    -> Expr Mutez+    -> Expr s+    -> Var Address+    -- ^ Variable that will be assigned to the resulting 'Address'+    -> Instruction+  SelfCalling+    :: ( NiceParameterFull p+       , KnownValue (GetEntrypointArgCustom p mname)+       , IsoValue (ContractRef (GetEntrypointArgCustom p mname))+       , IsNotInView+       )+    => Proxy p+    -> EntrypointRef mname+    -> Var (ContractRef (GetEntrypointArgCustom p mname))+    -- ^ Variable that will be assigned to the resulting 'ContractRef'+    -> Instruction+  ContractCalling+    :: ( HasEntrypointArg cp epRef epArg+       , ToTAddress cp vd addr+       , ToT addr ~ ToT Address+       , KnownValue epArg+       , IsoValue (ContractRef epArg)+       )+    => Proxy (cp, vd)+    -> epRef+    -> Expr addr+    -> Var (Maybe (ContractRef epArg))+    -- ^ Variable that will be assigned to the resulting 'ContractRef'+    -> Instruction+  Emit :: (HasSideEffects, NicePackedValue a, HasAnnotation a) => FieldAnn -> Expr a -> Instruction++  Fail+    :: (forall inp. SomeIndigoState inp)+    -> Instruction+  FailOver+    :: (forall inp. Expr a -> SomeIndigoState inp)+    -> Expr a+    -> Instruction++----------------------------------------------------------------------------+-- Translations+----------------------------------------------------------------------------++-- | Data type internally used to collect 'Instruction's from 'IndigoM'+data InstrCollector = InstrCollector+  { nextRef   :: RefId+  , instrList :: Block+  , seqHooks  :: SequentialHooks+  }++newtype SequentialHooks = SequentialHooks {+    shStmtHook    :: CallStack -> Block -> State InstrCollector ()+  }++instance Semigroup SequentialHooks where+  SequentialHooks s <> SequentialHooks s1 = SequentialHooks (\t -> s t >> s1 t)++instance Monoid SequentialHooks where+  mempty = SequentialHooks (const $ appendNewInstrs . reverse)++appendNewInstrs :: Block -> State InstrCollector ()+appendNewInstrs blk = modify $ \iColl -> iColl {instrList = blk ++ instrList iColl}++----------------------------------------------------------------------------+-- Case machinery+----------------------------------------------------------------------------++-- | Common constraint for case-like 'Instruction's.+type CaseCommon dt ret clauses = CaseCommonF IndigoSeqCaseClause dt ret clauses++-- | Analogous datatype as 'IndigoCaseClauseL' and 'IndigoMCaseClauseL'.+data IndigoSeqCaseClause ret (param :: CaseClauseParam) where+  OneFieldIndigoSeqCaseClause+    :: (AppendSymbol "c" ctor ~ name)+    => Label name+    -> CaseBranch x ret+    -> IndigoSeqCaseClause ret ('CaseClauseParam ctor ('OneField x))++-- | Representation of a branch of a generic case-like 'Instruction'.+data CaseBranch x ret where+  CaseBranch+    :: ( KnownValue x+       , ScopeCodeGen retBr+       , ret ~ RetExprs retBr+       , RetOutStack ret ~ RetOutStack retBr+       )+    => Var x+    -- ^ Input variable (accessible to the branch's code block)+    -> Block+    -- ^ Code block for this branch+    -> retBr+    -- ^ Return value of this branch+    -> CaseBranch x ret++makeLensesFor [ ("shStmtHook", "stmtHookL")] ''SequentialHooks