indigo 0.3.1 → 0.4

raw patch · 36 files changed

+1245/−446 lines, 36 filesdep +casingdep +microlens-thdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: casing, microlens-th, template-haskell

API changes (from Hackage documentation)

Files

• CHANGES.md +19/−0
• README.md +1/−1
• app/Main.hs +5/−5
• indigo.cabal +14/−7
• src/Indigo/Backend.hs +42/−23
• src/Indigo/Backend/Case.hs +17/−9
• src/Indigo/Backend/Conditional.hs +27/−27
• src/Indigo/Backend/Error.hs +16/−14
• src/Indigo/Backend/Lambda.hs +52/−32
• src/Indigo/Backend/Scope.hs +65/−13
• src/Indigo/Backend/Var.hs +29/−18
• src/Indigo/Compilation.hs +57/−30
• src/Indigo/Compilation/Hooks.hs +129/−0
• src/Indigo/Compilation/Lambda.hs +4/−2
• src/Indigo/Compilation/Sequential.hs +47/−17
• src/Indigo/Frontend/Language.hs +185/−110
• src/Indigo/Frontend/Statement.hs +10/−0
• src/Indigo/Internal/Expr/Compilation.hs +27/−25
• src/Indigo/Internal/Expr/Decompose.hs +7/−5
• src/Indigo/Internal/Expr/Symbolic.hs +25/−12
• src/Indigo/Internal/Expr/TH.hs +130/−0
• src/Indigo/Internal/Expr/Types.hs +39/−12
• src/Indigo/Internal/Lookup.hs +28/−24
• src/Indigo/Internal/Object.hs +2/−1
• src/Indigo/Internal/SIS.hs +0/−1
• src/Indigo/Internal/State.hs +85/−7
• src/Indigo/Internal/Var.hs +35/−16
• src/Indigo/Lorentz.hs +1/−0
• src/Indigo/Print.hs +10/−7
• test/Test/Code/Examples.hs +21/−13
• test/Test/Code/Expr.hs +5/−5
• test/Test/DebugComments.hs +93/−0
• test/Test/Examples.hs +2/−2
• test/Test/Lambda.hs +1/−1
• test/Test/Lookup.hs +6/−6
• test/Test/Util/Golden.hs +9/−1

@@ -1,3 +1,22 @@+0.4+==========+* [!8](https://gitlab.com/morley-framework/indigo/-/merge_requests/8)+  Comply with the recent changes in Lorentz.+  Namely, `pack`, `unpack`, `checkSignature` and hashing instructions now operate not with `ByteString`s and `Signature`s, rather with type-safe newtypes over them.+  Added `packRaw` and `unpackRaw` with the old behaviour of `pack` and `unpack`.+* [!5](https://gitlab.com/morley-framework/indigo/-/merge_requests/5)+  Replaced `indigo-trial` name with `indigo` via docker instead.+* [!630](https://gitlab.com/morley-framework/morley/-/merge_requests/630)+  Use `:` in all library instructions instead of `&`.+* [!639](https://gitlab.com/morley-framework/morley/-/merge_requests/639)+  Update the tutorial on how to install `indigo-trial` which is a wrapper around+  docker image that contains `indigo` binary and cached Haskell dependencies.+* [!596](https://gitlab.com/morley-framework/morley/-/merge_requests/596)+  Add ability to generate debug comments for Indigo statements:+  + Added several levels of verbosity+  + Added possibility to print full stack trace among with a statement call+  + `Buildable Expr` defined+ 0.3.1 ===== * Update `indigo` executable:

@@ -32,4 +32,4 @@  Indigo has a tutorial that you can find at [indigo-lang.gitlab.io](https://indigo-lang.gitlab.io/). -In addition, as for the other Morley projects, it has [Haddock documentation](https://hackage.haskell.org/package/indigo).+Additionally, like the other Morley projects, it has [Haddock documentation](https://hackage.haskell.org/package/indigo).

@@ -9,10 +9,9 @@ import Data.Text (dropWhileEnd) import qualified Data.Text.IO.Utf8 as Utf8 import Data.Version (showVersion)-import Main.Utf8 (withUtf8) import Options.Applicative-  (command, execParser, fullDesc, header, help, helper, info, infoOption, long,-  progDesc, subparser)+  (command, execParser, fullDesc, header, help, helper, info, infoOption, long, progDesc,+  subparser) import qualified Options.Applicative as Opt import Paths_indigo (version) import qualified Shelly as S@@ -20,9 +19,10 @@ import qualified System.Environment as SE import System.Process +import Util.Main (wrapMain)+ import qualified FileGen import Helper-import Util.Exception (displayUncaughtException)  data CmdLnArgs   = New Text@@ -74,7 +74,7 @@     newArgOption = Opt.strArgument (Opt.metavar "PROJECT NAME")  main :: IO ()-main = displayUncaughtException $ withUtf8 $ do+main = wrapMain $ do   r <- isRunCommand   case r of     Just input -> do

@@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack  name:           indigo-version:        0.3.1+version:        0.4 synopsis:       Convenient imperative eDSL over Lorentz. description:    Syntax and implementation of Indigo eDSL. category:       Language homepage:       https://indigo-lang.gitlab.io/-bug-reports:    https://gitlab.com/morley-framework/morley/-/issues+bug-reports:    https://gitlab.com/morley-framework/indigo/-/issues author:         Serokell, Tocqueville Group maintainer:     Serokell <hi@serokell.io> copyright:      2019-2020 Tocqueville Group@@ -23,7 +23,7 @@  source-repository head   type: git-  location: git@gitlab.com:morley-framework/morley.git+  location: git@gitlab.com:morley-framework/indigo.git  library   exposed-modules:@@ -38,6 +38,7 @@       Indigo.Backend.Var       Indigo.Compilation       Indigo.Compilation.Field+      Indigo.Compilation.Hooks       Indigo.Compilation.Lambda       Indigo.Compilation.Params       Indigo.Compilation.Sequential@@ -50,6 +51,7 @@       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@@ -68,17 +70,21 @@       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 NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns DeriveAnyClass DerivingStrategies 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+  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   build-depends:       base >=4.7 && <5+    , casing     , constraints     , containers+    , fmt     , lorentz+    , microlens-th     , morley     , morley-prelude     , reflection     , singletons+    , template-haskell     , vinyl     , with-utf8   mixins:@@ -96,7 +102,7 @@       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 NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  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   build-depends:       base >=4.7 && <5@@ -123,6 +129,7 @@       Test.Code.Examples       Test.Code.Expr       Test.Code.Lambda+      Test.DebugComments       Test.Decomposition       Test.Examples       Test.Expr@@ -134,7 +141,7 @@       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 NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns DeriveAnyClass DerivingStrategies NoApplicativeDo RebindableSyntax FunctionalDependencies+  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"   build-tool-depends:       tasty-discover:tasty-discover

@@ -46,8 +46,10 @@ import Indigo.Backend.Scope as ReExports import Indigo.Backend.Var as ReExports +import Fmt (build, fmt, pretty, (+|), (|+))+ import Indigo.Backend.Prelude-import Indigo.Internal+import Indigo.Internal hiding ((<>)) import Indigo.Lorentz import qualified Lorentz.Doc as L import qualified Lorentz.Entrypoints.Doc as L (finalizeParamCallingDoc)@@ -69,30 +71,39 @@   -- ^ Block of code to execute, as long as the expression holds 'True'   -> IndigoState inp inp while e body = IndigoState $ \md ->-  let expCd = gcCode $ usingIndigoState md (compileExpr e)+  let expCd = exprHook md (pretty e) $ gcCode $ usingIndigoState md (compileExpr e)       bodyIndigoState = runSIS body md cleanGenCode-  in GenCode (mdStack md) (expCd # L.loop (bodyIndigoState # expCd)) L.nop+  in flip (GenCode (mdStack md)) L.nop $+        stmtHook md ("while (" <> pretty e <> ")") $+          expCd #+          L.loop (bodyIndigoState #+                  expCd)  -- | While-left statement. Repeats a block of code as long as the control -- 'Either' is 'Left', returns when it is 'Right'. whileLeft-  :: (KnownValue l, KnownValue r)+  :: forall l r inp . (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)-  -> SomeIndigoState (l & inp)+  -> SomeIndigoState (l : inp)   -- ^ Code block to execute while the value is 'Left'   -> Var r   -- ^ Variable that will be assigned to the resulting value-  -> IndigoState inp (r & inp)+  -> IndigoState inp (r : inp) whileLeft e varL body varR = IndigoState $ \md ->   let-    cde = gcCode $ usingIndigoState md (compileExpr e)+    cde = exprHook md (pretty e) $ gcCode $ usingIndigoState md (compileExpr e)     newMd = pushRefMd varL md-    gc = runSIS body newMd cleanGenCode+    bodyCd = runSIS body newMd cleanGenCode     resSt = pushRef varR $ mdStack md-  in GenCode resSt (cde # L.loopLeft (gc # L.drop # cde)) L.drop+  in flip (GenCode resSt) L.drop $+        stmtHook md (condStmtPretty @(Var r) varR "whileLeft" e) $+          exprHook md (pretty e) cde #+          L.loopLeft (auxiliaryHook md ("body: " <> pretty varL <> ":= fromLeft " <> pretty e) bodyCd #+                      L.drop #+                      cde)  -- | For statements to iterate over a container. forEach@@ -101,14 +112,16 @@   -- ^ Expression for the container to traverse   -> Var (IterOpElHs a)   -- ^ Variable for the current item (available to the code block)-  -> SomeIndigoState ((IterOpElHs a) & inp)+  -> SomeIndigoState ((IterOpElHs a) : inp)   -- ^ Code block to execute over each element of the container   -> IndigoState inp inp forEach container var body = IndigoState $ \md ->   let cde = gcCode $ usingIndigoState md (compileExpr container)       newMd = pushRefMd var md       bodyIndigoState = runSIS body newMd cleanGenCode-  in GenCode (mdStack md) (cde # L.iter (bodyIndigoState # L.drop)) L.nop+  in flip (GenCode (mdStack md)) L.nop $ stmtHook md (fmt $ "foreach (" +| var |+ " in " +| container |+ ")") $+        exprHook md (pretty container) cde #+        L.iter (bodyIndigoState # L.drop)  ---------------------------------------------------------------------------- -- Documentation@@ -147,14 +160,17 @@ finalizeParamCallingDoc   :: (NiceParameterFull cp, RequireSumType cp, HasCallStack)   => Var cp-  -> SomeIndigoState (cp & inp)+  -> SomeIndigoState (cp : inp)   -> Expr cp   -> SomeIndigoState inp finalizeParamCallingDoc vc act param = SomeIndigoState $ \md ->   let cde = gcCode $ usingIndigoState md (compileExpr param)       newMd = pushRefMd vc md   in runSIS act newMd $ \(GenCode st1 cd clr) ->-    SomeGenCode $ GenCode st1 (cde # L.finalizeParamCallingDoc cd) (clr # L.drop)+    SomeGenCode $ flip (GenCode st1) (clr # L.drop) $+    stmtHook md ("finalizeParamCallingDoc (" <> pretty param <> ")") $+      exprHook md (pretty param) cde #+      L.finalizeParamCallingDoc cd  ---------------------------------------------------------------------------- -- Contract call@@ -168,8 +184,8 @@   => EntrypointRef mname   -> Var (ContractRef (GetEntrypointArgCustom p mname))   -- ^ Variable that will be assigned to the resulting 'ContractRef'-  -> IndigoState inp (ContractRef (GetEntrypointArgCustom p mname) & inp)-selfCalling epRef var = do+  -> IndigoState inp (ContractRef (GetEntrypointArgCustom p mname) : inp)+selfCalling epRef var = stmtHookState (pretty var <> " := selfCalling " <> pretty (eprName epRef)) $ do   nullaryOp (L.selfCalling @p epRef)   assignTopVar var @@ -184,8 +200,8 @@   -> Expr addr   -> Var (Maybe (ContractRef epArg))   -- ^ Variable that will be assigned to the resulting 'ContractRef'-  -> IndigoState inp (Maybe (ContractRef epArg) & inp)-contractCalling epRef addr var = do+  -> IndigoState inp (Maybe (ContractRef epArg) : inp)+contractCalling epRef addr var = stmtHookState (pretty var <> " := contractCalling " <> pretty addr) $ do   unaryOp addr (L.contractCalling @cp epRef)   assignTopVar var @@ -212,11 +228,12 @@   -> Expr s   -> Var Address   -- ^ Variable that will be assigned to the resulting 'Address'-  -> IndigoState inp (Address & inp)-createContract lCtr ek em es var = do-  withStackVars $ \s ->-    ternaryOp ek em es $ L.createContract lCtr # varActionOperation (NoRef :& s)-  assignTopVar var+  -> IndigoState inp (Address : inp)+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)+    assignTopVar var  ---------------------------------------------------------------------------- -- Functions, Procedures and Scopes@@ -257,7 +274,9 @@   -- ^ Variable(s) that will be assigned to the resulting value(s)   -> IndigoState inp (RetOutStack ret ++ inp) scope f ret retVars = IndigoState $ \md@MetaData{..} ->-  runSIS f md $ \fs -> finalizeStatement @ret mdStack retVars $ compileScope @ret mdObjects fs ret+  runSIS f md $ \fs ->+    finalizeStatement @ret mdStack retVars $ stmtHook md (prettyAssign @ret retVars "scope") $+      compileScope @ret (replStkMd md) fs ret  -- | Add a comment comment :: MT.CommentType -> IndigoState i i

@@ -17,12 +17,13 @@   ) where  import Data.Vinyl.Core (RMap(..))+import Fmt (pretty) import Util.Type (type (++)) import Util.TypeLits (AppendSymbol)  import Indigo.Backend.Prelude import Indigo.Backend.Scope-import Indigo.Internal+import Indigo.Internal hiding ((<>)) import Indigo.Lorentz import qualified Lorentz.ADT as L import qualified Lorentz.Entrypoints.Doc as L@@ -67,12 +68,13 @@         (SomeIndigoState body :: SomeIndigoState (x : inp)) ->           -- Create a reference to the top of stack           case body (pushRefMd varCase md) of-            SomeGenCode gc ->+            SomeGenCode bodyCd ->               CaseClauseL $-                -- Compute returning expressions and clean up everything-                compileScope @retBr mdObjects gc ret #-                -- Remove @x@ from the stack too-                liftClear @retBr @inp @(x : inp) L.drop+                auxiliaryHook md ("case branch against " <> pretty varCase) $+                  -- Compute returning expressions and clean up everything+                  compileScope @retBr (\stk -> MetaData stk mdObjects mdHooks) bodyCd ret #+                  -- Remove @x@ from the stack too+                  liftClear @retBr @inp @(x : inp) L.drop  -- | This constraint is shared by all @case*@ functions. -- Including some outside this module.@@ -96,7 +98,9 @@   -> IndigoState inp (RetOutStack ret ++ inp) caseRec g cls vars = IndigoState $ \md ->   let cdG = gcCode $ usingIndigoState md (compileExpr g) in-  finalizeStatement @ret (mdStack md) vars (cdG # L.case_ (toCaseClauseL md cls))+  finalizeStatement @ret (mdStack md) vars $ stmtHook md (condStmtPretty @ret vars "caseRec" g) $+    exprHook md (pretty g) cdG #+    L.case_ (toCaseClauseL md cls)  -- | 'case_' for pattern-matching on parameter. entryCaseRec@@ -112,7 +116,9 @@   -> IndigoState inp (RetOutStack ret ++ inp) entryCaseRec proxy g cls vars = IndigoState $ \md ->   let cdG = gcCode $ usingIndigoState md (compileExpr g) in-  finalizeStatement @ret (mdStack md) vars(cdG # L.entryCase_ proxy (toCaseClauseL md cls))+  finalizeStatement @ret (mdStack md) vars $ stmtHook md (condStmtPretty @ret vars "entryCaseRec" g) $+    exprHook md (pretty g) cdG #+    L.entryCase_ proxy (toCaseClauseL md cls)  -- | 'entryCase_' for contracts with flat parameter. entryCaseSimpleRec@@ -129,7 +135,9 @@   -> IndigoState inp (RetOutStack ret ++ inp) entryCaseSimpleRec g cls vars = IndigoState $ \md ->   let cdG = gcCode $ usingIndigoState md (compileExpr g) in-  finalizeStatement @ret (mdStack md) vars (cdG # L.entryCaseSimple_ (toCaseClauseL md cls))+  finalizeStatement @ret (mdStack md) vars $ stmtHook md (condStmtPretty @ret vars "entryCaseSimpleRec" g) $+    exprHook md (pretty g) cdG #+    L.entryCaseSimple_ (toCaseClauseL md cls)  toCaseClauseL   :: forall inp ret cs .

@@ -20,7 +20,7 @@  import Indigo.Backend.Prelude import Indigo.Backend.Scope-import Indigo.Internal+import Indigo.Internal hiding ((<>)) import Indigo.Lorentz import qualified Lorentz.Instr as L import qualified Lorentz.Macro as L@@ -62,17 +62,18 @@   let cde = gcCode $ usingIndigoState md (compileExpr e) in   runSIS t md $ \gc1 ->     runSIS f md $ \gc2 ->-      finalizeStatement @a mdStack retVars $-        cde # L.if_ (compileScope @a mdObjects gc1 retA) (compileScope @b mdObjects gc2 retB)+      finalizeStatement @a mdStack retVars $ stmtHook md (condStmtPretty @a retVars "if" e) $+        exprHook md (prettyRet e) cde #+        L.if_ (compileScope @a (replStkMd md) gc1 retA) (compileScope @b (replStkMd md) gc2 retB) --- | If which works like case for Maybe.+-- | If-statement that works like case for Maybe. ifSome   :: forall inp x a b . (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)-  -> SomeIndigoState (x & inp)+  -> SomeIndigoState (x : inp)   -- ^ Code block for the 'Just' branch   -> a   -- ^ Return value(s) of the 'Just' branch@@ -84,19 +85,19 @@   -- ^ Variable(s) that will be assigned to the resulting value(s)   -> IndigoState inp (RetOutStack a ++ inp) ifSome e varX t retA f retB retVars = IndigoState $ \md@MetaData{..} ->-  let cde = gcCode $ usingIndigoState md (compileExpr e) in+  let cde    = gcCode $ usingIndigoState md (compileExpr e) in   let mdJust = pushRefMd varX md in   runSIS t mdJust $ \gc1 ->     runSIS f md $ \gc2 ->-      finalizeStatement @a mdStack retVars $-        cde #+      finalizeStatement @a mdStack retVars $ stmtHook md (condStmtPretty @a retVars "ifSome" e) $+        exprHook md (prettyRet e) cde #         L.ifSome-          ( compileScope @a mdObjects gc1 retA #+          ( compileScope @a (replStkMd md) gc1 retA #             -- after this we have stack (e1 & e2 .. & ek & x & inp)-            liftClear' @(ClassifyReturnValue a) @a @(x & inp) @inp L.drop-            -- this can be lifted together with glClear code, but let's leave it like this for now+            liftClear' @(ClassifyReturnValue a) @a @(x : inp) @inp L.drop+            -- this can be lifted together with 'gcClear' code, but let's leave it like this for now           )-          (compileScope @b mdObjects gc2 retB)+          (compileScope @b (replStkMd md) gc2 retB)  -- | If which works like case for Either. ifRight@@ -105,13 +106,13 @@   -- ^ Expression for the control flow   -> Var r   -- ^ Variable for the 'Right' value (available to the next code block)-  -> SomeIndigoState (r & inp)+  -> SomeIndigoState (r : inp)   -- ^ 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)-  -> SomeIndigoState (l & inp)+  -> SomeIndigoState (l : inp)   -- ^ Code block for the 'Left' branch   -> b   -- ^ Return value(s) of the 'Left' branch@@ -126,17 +127,17 @@   in     runSIS r mdRight $ \gc1 ->       runSIS l mdLeft $ \gc2 ->-        finalizeStatement @a mdStack retVars $-          cde #+        finalizeStatement @a mdStack retVars $ stmtHook md (condStmtPretty @a retVars "ifRight" e) $+          exprHook md (prettyRet e) cde #           L.ifRight-            ( compileScope @a mdObjects gc1 retA #+            ( compileScope @a (replStkMd md) gc1 retA #             -- after this we have stack (e1 & e2 .. & ek & x & inp)-            liftClear' @(ClassifyReturnValue a) @a @(r & inp) @inp L.drop+            liftClear' @(ClassifyReturnValue a) @a @(r : inp) @inp L.drop             -- this can be lifted together with glClear code, but let's leave it like this for now             )-            ( compileScope @b mdObjects gc2 retB #+            ( compileScope @b (replStkMd md) gc2 retB #             -- after this we have stack (e1 & e2 .. & ek & x & inp)-            liftClear' @(ClassifyReturnValue b) @b @(l & inp) @inp L.drop+            liftClear' @(ClassifyReturnValue b) @b @(l : inp) @inp L.drop             -- this can be lifted together with glClear code, but let's leave it like this for now             ) @@ -149,7 +150,7 @@   -- ^ 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)-  -> SomeIndigoState (x & List x & inp)+  -> SomeIndigoState (x : List x : inp)   -- ^ Code block for the non-empty list branch   -> a   -- ^ Return value(s) of the non-empty list branch@@ -168,10 +169,9 @@   in     runSIS t mdVal $ \gc1 ->       runSIS f md $ \gc2 ->-        finalizeStatement @a mdStack retVars $-          cde #+        finalizeStatement @a mdStack retVars $ stmtHook md (condStmtPretty @a retVars "ifCons" e) $+          exprHook md (prettyRet e) cde #           L.ifCons-            ( compileScope @a mdObjects gc1 retA #-              liftClear' @(ClassifyReturnValue a) @a @(x & List x & inp) @inp (L.drop # L.drop)-            )-            (compileScope @b mdObjects gc2 retB)+            ( compileScope @a (replStkMd md) gc1 retA #+              liftClear' @(ClassifyReturnValue a) @a @(x : List x : inp) @inp (L.drop # L.drop))+            (compileScope @b (replStkMd md) gc2 retB)

@@ -14,10 +14,13 @@   , failUnexpected_   ) where +import Fmt (Buildable, pretty)+ import Indigo.Backend.Prelude import Indigo.Internal.Expr.Compilation import Indigo.Internal.Expr.Types import Indigo.Internal.State+import Indigo.Internal.Var import Indigo.Lorentz import qualified Lorentz.Errors as L import qualified Lorentz.Instr as L@@ -26,19 +29,16 @@ failIndigoState :: inp :-> out -> IndigoState inp out failIndigoState gcCode = iput $ GenCode {..}   where-    -- note: here we can use errors for the output and MetaData, because they-    -- are lazy field of GenCode and, due to the way # combines the generated-    -- code (ignores everything following a failWith) they won't actually ever-    -- be accessed again. The same goes for the "cleaning" code, except it is-    -- not lazy and needs to typecheck, so we have to use `failWith` again.-    gcStack = error $ "StackVars is undefined after a failing instruction"+    gcStack = FailureStack     gcClear = L.unit # L.failWith  failWith :: KnownValue a => Expr a -> IndigoState s t-failWith exa = compileExpr exa >> failIndigoState L.failWith+failWith exa = stmtHookState ("failWith (" <> pretty exa <> ")") $+  exprHookState (pretty exa) (compileExpr exa) >>+  failIndigoState L.failWith -failUsing_ :: (IsError x) => x -> IndigoState s t-failUsing_ x = failIndigoState (failUsing x)+failUsing_ :: (IsError x, Buildable x) => x -> IndigoState s t+failUsing_ x = stmtHookState ("failUsing_ (" <> pretty x <> ")") $ failIndigoState (failUsing x)  failCustom   :: forall tag err s t.@@ -47,9 +47,10 @@      , NiceConstant err      )   => Label tag -> Expr err -> IndigoState s t-failCustom l errEx = withDict (niceConstantEvi @err) $ do-  compileExpr errEx-  failIndigoState $ L.failCustom l+failCustom l errEx = stmtHookState ("failCustom (" <> pretty errEx <> ")") $+  withDict (niceConstantEvi @err) $ do+    exprHookState (pretty errEx) (compileExpr errEx)+    failIndigoState $ L.failCustom l  failCustom_   :: forall tag s t notVoidErrorMsg.@@ -57,7 +58,8 @@      , CustomErrorHasDoc tag      )   => Label tag -> IndigoState s t-failCustom_ = failIndigoState . L.failCustom_+failCustom_ = stmtHookState "failCustom_" . failIndigoState . L.failCustom_  failUnexpected_ :: MText -> IndigoState s t-failUnexpected_ msg = failUsing_ $ [mt|Unexpected: |] <> msg+failUnexpected_ msg =+  stmtHookState ("failUnexpected_ (" <> pretty msg <> ")") . failUsing_ $ [mt|Unexpected: |] <> msg

@@ -25,6 +25,7 @@   ) where  import Data.Constraint (Dict(..))+import Fmt (fmt, pretty, (+|), (|+))  import Indigo.Backend.Prelude import Indigo.Backend.Scope@@ -65,22 +66,32 @@ -- | Execute lambda depending on its 'LambdaKind' executeLambda1   :: forall res st arg extra inp .-  LambdaKind st arg res extra -> RefId -> RetVars res -> LambdaExecutor extra arg res inp-executeLambda1 PureLambda _ retVars = executeLambdaPure1 @res retVars-executeLambda1 (StorageLambda _) refId retVars = executeLambdaSt1 @res refId retVars-executeLambda1 (EffLambda _) refId retVars = executeLambdaEff1 @res refId retVars+     LambdaKind st arg res extra+  -- ^ Kind of lambda+  -> RefId+  -- ^ Next free variable reference+  -> RetVars res+  -- ^ Variable that will be assigned to the resulting value+  -> LambdaExecutor extra arg res inp+executeLambda1 lambdaKind refId retVars lambdaVar argEx = withLambdaKind lambdaKind $+  let execStmt = fmt $ "executeLambda (lambdaVar = " +| lambdaVar |+ ", arg = " +| argEx |+ ")" in+  stmtHookState (prettyAssign @res retVars execStmt) $+    case lambdaKind of+      PureLambda      -> executeLambdaPure1 @res       retVars lambdaVar argEx+      StorageLambda _ -> executeLambdaSt1   @res refId retVars lambdaVar argEx+      EffLambda _     -> executeLambdaEff1  @res refId retVars lambdaVar argEx  -- | Create initial stack vars depending on 'LambdaKind'-initLambdaStackVars :: LambdaKind st arg res extra -> Var arg -> StackVars (arg & extra)+initLambdaStackVars :: LambdaKind st arg res extra -> Var arg -> StackVars (arg : extra) initLambdaStackVars PureLambda = initStackVarsPure initLambdaStackVars (StorageLambda _) = initStackVars initLambdaStackVars (EffLambda _) = initStackVarsEff -type Lambda1Generic extra arg res = (arg & extra) :-> (RetOutStack res ++ extra)+type Lambda1Generic extra arg res = (arg : extra) :-> (RetOutStack res ++ extra)  type CreateLambda1CGeneric extra arg res =   ( ScopeCodeGen res, KnownValue arg, Typeable extra-  , ZipInstr (arg & extra)+  , ZipInstr (arg : extra)   , KnownValue (ZippedStack (arg ': extra))   , KnownValue (ZippedStack (RetOutStack res ++ extra))   , ZipInstr (RetOutStack res ++ extra)@@ -93,16 +104,19 @@   :: forall arg res extra inp . CreateLambda1CGeneric extra arg res   => Var (Lambda1Generic extra arg res)   -> res-  -> StackVars (arg & extra)-  -> SomeIndigoState (arg & extra)-  -> IndigoState inp (Lambda1Generic extra arg res & inp)-createLambda1Generic var ret initMd act = IndigoState $ \MetaData{..} ->+  -> StackVars (arg : extra)+  -> SomeIndigoState (arg : extra)+  -> IndigoState inp (Lambda1Generic extra arg res : inp)+createLambda1Generic var ret initMd act = IndigoState $ \md@MetaData{..} ->   -- Decomposed objects are passed as mempty here because in the lambda   -- we don't decompose storage value (but we might be doing it as an optimisation)   -- so we just have it as an stack cell-  runSIS act (MetaData initMd mempty) $ \gc ->+  runSIS act (MetaData initMd mempty mdHooks) $ \lambdaBody ->     let gcStack = pushRef var mdStack-        gcCode = L.lambda (compileScope mdObjects gc ret # liftClear @res @extra @(arg & extra) L.drop)+        gcCode =+          stmtHook md (prettyAssign @(Var (Lambda1Generic extra arg res)) var "createLambda") $+            L.lambda (compileScope (replStkMd md) lambdaBody ret #+                      liftClear @res @extra @(arg : extra) L.drop)         gcClear = L.drop     in GenCode {..} @@ -150,12 +164,15 @@           -- TODO this @compileExpr (V (storageVar @st))@ call materialises the whole decomposed storage.           -- This is pretty expensive operation and it has to be fixed:           -- we have to materialise only fields used in the lambda-          GenCode gcStack fetchCode _ = usingIndigoState md $ compileExpr (V storage)+          GenCode resStack fetchStorage _ =+            usingIndigoState md $ exprHookState "Computing storage" $ compileExpr (V storage)           tmpVar = Var nextRef-          gcClear = gcCode (usingIndigoState (pushRefMd tmpVar md) $-                              setVar (nextRef + 1) storage (V tmpVar))-                    # L.drop-      in GenCode {gcCode=fetchCode,..}+          setStorage =+            auxiliaryHook md "Update storage with returned from lambda" $+              gcCode (usingIndigoState (pushRefMd tmpVar md) $+                      setVar (nextRef + 1) storage (V tmpVar))+              # L.drop+      in GenCode resStack fetchStorage setStorage   initStackVars :: (HasStorage st, KnownValue arg) => Var arg -> StackVars '[arg, st]@@ -192,19 +209,22 @@     -- TODO this @compileExpr (V (storageVar @st))@ call materialises the whole decomposed storage.     -- This is pretty expensive operation and it has to be fixed:     -- we have to materialise only fields used in the lambda-    IndigoState $ \MetaData{..} ->+    IndigoState $ \md@MetaData{..} ->       let storage = storageVar @st           ops@(Var opsRefId) = operationsVar           gcStack = pushRef storage $ pushRef ops mdStack           fetchCode =-            varActionGet opsRefId mdStack #-            (gcCode $ usingIndigoState (MetaData sPlus mdObjects) $ compileExpr (V storage))-          sPlus = NoRef :& mdStack+            auxiliaryHook md "Fetching operations" (varActionGet opsRefId mdStack) #+            (exprHook md "Computing storage" $+              gcCode $ usingIndigoState (replStkMd md sPlus) $ compileExpr (V storage))+          sPlus = pushNoRef mdStack           tmpVar = Var nextRef-          setStorage = gcCode (usingIndigoState (MetaData (pushRef tmpVar sPlus) mdObjects) $-                                 setVar (nextRef + 1) storage (V tmpVar))-                       # L.drop-          gcClear = setStorage # varActionSet opsRefId mdStack+          setStorage =+            auxiliaryHook md "Update storage with returned from lambda" $+              gcCode (usingIndigoState (replStkMd md (pushRef tmpVar sPlus)) $ setVar (nextRef + 1) storage (V tmpVar))+              # L.drop+          gcClear = setStorage #+                    auxiliaryHook md "Update operations with returned from lambda" (varActionSet opsRefId mdStack)       in GenCode {gcCode=fetchCode,..}  initStackVarsEff@@ -221,9 +241,9 @@  type ExecuteLambda1CGeneric extra arg res =   ( ScopeCodeGen res, KnownValue arg-  , KnownValue ((arg & extra) :-> (RetOutStack res ++ extra))+  , KnownValue ((arg : extra) :-> (RetOutStack res ++ extra))   , KnownList extra-  , ZipInstr (arg & extra)+  , ZipInstr (arg : extra)   , KnownList (RetOutStack res ++ extra)   , ZipInstr (RetOutStack res ++ extra)   , Typeable (RetOutStack res ++ extra)@@ -247,11 +267,11 @@ executeLambda1Generic vars allocateCleanup varF argm = IndigoState $ \md@MetaData{..} ->   let GenCode allocStk allocate cleanup = usingIndigoState md allocateCleanup in   let getArgs =-        allocate #+        auxiliaryHook md "Computing implicit lambda arguments" allocate #         (gcCode $-          usingIndigoState (MetaData allocStk mdObjects) $ do-              compileExpr argm-              compileExpr (V varF)) in+          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 #

@@ -38,14 +38,20 @@   , compileScope   , allocateVars   , finalizeStatement++  -- Builder helpers for hooks+  , prettyAssign+  , condStmtPretty+  , prettyRet   ) where  import qualified Data.Kind as Kind+import Fmt (Buildable(..), pretty) import qualified GHC.TypeLits as Lit import Util.Type (type (++))  import Indigo.Backend.Prelude-import Indigo.Internal.Expr+import Indigo.Internal.Expr hiding ((<>)) import Indigo.Internal.State import Indigo.Internal.Var import Indigo.Lorentz@@ -115,6 +121,12 @@     -> StackVars inp     -> StackVars (RetOutStack' retKind ret ++ inp) +  -- | Pretty printing of statements like \"var := statement\"+  prettyAssign' :: RetVars' retKind ret -> Text -> Text++  -- | Prettify 'ret' value+  prettyRet' :: ret -> Text+ -- | Type class which unions all related management of computations in a scope, -- like in @if@ branch, in @case@ body, etc. --@@ -162,18 +174,35 @@   -> (RetOutStack ret ++ xs :-> RetOutStack ret ++ inp) liftClear = liftClear' @(ClassifyReturnValue ret) @ret +prettyAssign :: forall ret . ReturnableValue ret => RetVars ret -> Text -> Text+prettyAssign = prettyAssign' @(ClassifyReturnValue ret) @ret++prettyRet :: forall ret . ReturnableValue ret => ret -> Text+prettyRet = prettyRet' @(ClassifyReturnValue ret) @ret++condStmtPretty :: forall ret x . ReturnableValue ret => RetVars ret -> Text -> Expr x -> Text+condStmtPretty retVars stmtName ex = prettyAssign @ret retVars (stmtName <> " (" <> pretty ex <> ")")+ -- | Concatenate a scoped code, generation of returning expressions, -- and clean up of redundant cells from the stack. compileScope   :: forall ret inp xs . ScopeCodeGen ret-  => DecomposedObjects+  => (StackVars xs -> MetaData xs)+  -- ^ Partially applied constructor of 'MetaData' (without passed 'StackVars').+  -- 'compileScope' function is usually being called from another function+  -- which is in 'IndigoState' and, consequently, holding 'MetaData' with all fields.   -> GenCode inp xs+  -- ^ Code (and clear) of a wrapping scope   -> ret+  -- ^ Return value of a scope (either primitives or expressions or variables)   -> (inp :-> RetOutStack ret ++ inp)-compileScope objs gc gcRet =-  gcCode gc #-  gcCode (usingIndigoState (MetaData (gcStack gc) objs) (compileScopeReturn' @(ClassifyReturnValue ret) gcRet)) #-  liftClear' @(ClassifyReturnValue ret) @ret (gcClear gc)+compileScope mdCr innerGc gcRet =+  let md = mdCr (gcStack innerGc) in+  gcCode innerGc #+  auxiliaryHook md ("computation of returning values: " <> prettyRet gcRet)+    (gcCode $ usingIndigoState md $ compileScopeReturn' @(ClassifyReturnValue ret) gcRet) #+  auxiliaryHook md "dropping cells from the stack allocated in the scope"+    (liftClear' @(ClassifyReturnValue ret) @ret (gcClear innerGc))  -- | Push variables in the 'StackVars', referring to the generated expressions, -- and generate 'gcClear' for the whole statement.@@ -200,50 +229,73 @@   type RetExprs' 'Unit () = ()   allocateVars' _ = pure ()   assignVars' _ md = md+  prettyAssign' _ stmt = stmt+  prettyRet' _ = "()"  instance ScopeCodeGen' 'Unit () where   compileScopeReturn' _ = nopState   liftClear' = id   genGcClear' = L.nop -instance KnownValueExpr single  => ReturnableValue' 'SingleVal single where+instance KnownValueExpr single => ReturnableValue' 'SingleVal single where   type RetOutStack' 'SingleVal single = '[ExprType single]   type RetVars' 'SingleVal single = Var (ExprType single)   type RetExprs' 'SingleVal single = ExprType single   allocateVars' allocator = allocator @(ExprType single)   assignVars' = pushRef+  prettyAssign' retVars stmt = pretty retVars <> " := " <> stmt+  prettyRet' = pretty . toExpr -instance KnownValueExpr single  => ScopeCodeGen' 'SingleVal single where+instance KnownValueExpr single => ScopeCodeGen' 'SingleVal single where   compileScopeReturn' = compileToExpr   liftClear' = L.dip   genGcClear' = L.drop -instance (KnownValueExpr x, KnownValueExpr y) => ReturnableValue' 'Tuple (x, y) where+instance ( KnownValueExpr x+         , KnownValueExpr y+         , Buildable (RetVars' 'Tuple (x, y))+         )+         => ReturnableValue' 'Tuple (x, y) where   type RetOutStack' 'Tuple (x, y) = ExprType x ': '[ExprType y]   type RetVars' 'Tuple (x, y) = (Var (ExprType x), Var (ExprType y))   type RetExprs' 'Tuple (x, y) = (ExprType x, ExprType y)   allocateVars' allocator = (,) <$> allocator <*> allocator   assignVars' (var1, var2) md = pushRef var1 $ pushRef var2 md+  prettyAssign' retVars stmt = pretty retVars <> " := " <> stmt+  prettyRet' (x, y) = "(" <> pretty (toExpr x) <> ", " <> pretty (toExpr y) <> ")" -instance (KnownValueExpr x, KnownValueExpr y) => ScopeCodeGen' 'Tuple (x, y) where+instance (KnownValueExpr x+         , KnownValueExpr y+         , 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   genGcClear' = L.drop # L.drop -instance (KnownValueExpr x, KnownValueExpr y, KnownValueExpr z) => ReturnableValue' 'Tuple (x, y, z) where+instance ( KnownValueExpr x+         , KnownValueExpr y+         , KnownValueExpr z+         , Buildable (RetVars' 'Tuple (x, y, z))+         ) => ReturnableValue' 'Tuple (x, y, z) where   type RetOutStack' 'Tuple (x, y, z) = ExprType x ': ExprType y ': '[ExprType z]   type RetVars' 'Tuple (x, y, z) = (Var (ExprType x), Var (ExprType y), Var (ExprType z))   type RetExprs' 'Tuple (x, y, z) = (ExprType x, ExprType y, ExprType z)   allocateVars' allocator = (,,) <$> allocator <*> allocator <*> allocator   assignVars' (var1, var2, var3) md =     pushRef var1 . pushRef var2 $ pushRef var3 md+  prettyAssign' retVars stmt = pretty retVars <> " := " <> stmt+  prettyRet' (x, y, z) = "(" <> pretty (toExpr x) <> ", " <> pretty (toExpr y) <> ", " <> pretty (toExpr z) <> ")" -instance (KnownValueExpr x, KnownValueExpr y, KnownValueExpr z) => ScopeCodeGen' 'Tuple (x, y, z) where+instance (KnownValueExpr x+         , KnownValueExpr y+         , KnownValueExpr z+         , Buildable (RetVars' 'Tuple (x, y, z))+         ) => ScopeCodeGen' 'Tuple (x, y, z) where   compileScopeReturn' (e1, e2, e3) = compileToExpr e3 >> compileToExpr e2 >> compileToExpr e1   liftClear' = L.dipN @3   genGcClear' = L.drop # L.drop # L.drop  -- | Utility function to compile from an 'IsExpr'-compileToExpr :: ToExpr a => a -> IndigoState inp ((ExprType a) & inp)+compileToExpr :: ToExpr a => a -> IndigoState inp ((ExprType a) : inp) compileToExpr = compileExpr . toExpr

@@ -11,16 +11,21 @@   , updateVar   ) where +import Fmt (pretty)+ import Indigo.Backend.Prelude-import Indigo.Internal hiding ((+))+import Indigo.Backend.Scope+import Indigo.Internal hiding ((+), (<>)) import Indigo.Lorentz import qualified Lorentz.Instr as L import Michelson.Typed.Haskell.Instr.Product (GetFieldType) import Util.Type (type (++))  -- | Assign the given variable to the value resulting from the given expression.-assignVar :: KnownValue x => Var x -> Expr x -> IndigoState inp (x & inp)-assignVar var e = compileExpr e >> assignTopVar var+assignVar :: forall x inp . KnownValue x => Var x -> Expr x -> IndigoState inp (x : inp)+assignVar var e =+  stmtHookState (prettyAssign @(Var x) var (pretty e)) $+    compileExpr e >> assignTopVar var  -- | Set the variable to a new value. --@@ -33,21 +38,23 @@ -- because all allocated variables will be destroyed during execution of the function, -- so allocated ones won't affect next allocated ones. setVar :: forall a inp. KnownValue a => RefId -> Var a -> Expr a -> IndigoState inp inp-setVar nextRef v ex = withObjectState v $ flip (setVarImpl nextRef) ex+setVar nextRef v ex = stmtHookState (prettyAssign @(Var a) v (pretty ex)) $+  withObjectState v $ flip (setVarImpl nextRef) ex  setVarImpl :: forall a inp . RefId -> Object a -> Expr a -> IndigoState inp inp-setVarImpl _ (Cell refId) ex = IndigoState $ \md ->-  usingIndigoState md $ unaryOpFlat ex $ varActionSet refId (mdStack md)-setVarImpl nextRef (Decomposed fields) ex = IndigoState $ \md -> case decomposeExpr (mdObjects md) ex of-  ExprFields fieldsExpr ->-    usingIndigoState md $ rmapZipM (namedToTypedRec @a namedToTypedFieldObj fields) fieldsExpr-  Deconstructed comp ->-    let GenCode decomposeSt decomposeExCd _ = usingIndigoState md comp in-    let setAllFieldsCd =-          setFieldsOnStack-            (MetaData decomposeSt $ mdObjects md)-            (namedToTypedRec @a namedToTypedFieldObj fields) in-    GenCode (mdStack md) (decomposeExCd # setAllFieldsCd) L.nop+setVarImpl _ (Cell refId) ex = IndigoState $ \md -> usingIndigoState md $+  unaryOpFlat ex $ varActionSet refId (mdStack md)+setVarImpl nextRef (Decomposed fields) ex = IndigoState $ \md@MetaData{..} ->+  case decomposeExpr mdObjects ex of+    ExprFields fieldsExpr -> usingIndigoState md $+      rmapZipM (namedToTypedRec @a namedToTypedFieldObj fields) fieldsExpr+    Deconstructed comp ->+      let GenCode decomposeSt decomposeExCd _ = usingIndigoState md comp+          setAllFieldsCd =+            setFieldsOnStack+              (MetaData decomposeSt mdObjects mdHooks)+              (namedToTypedRec @a namedToTypedFieldObj fields) in+      GenCode mdStack (decomposeExCd # setAllFieldsCd) L.nop   where     -- Set fields, if they are decomposed on stack.     setFieldsOnStack@@ -79,7 +86,9 @@      , HasField dt fname ftype      )   => RefId -> Var dt -> Label fname -> Expr ftype -> IndigoState inp inp-setField nextRef v targetLb e = withObjectState v setFieldImpl+setField nextRef v targetLb e =+  stmtHookState ("setField " <> pretty v <> " #" <> pretty targetLb <> " " <> pretty e) $+    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@@ -101,7 +110,9 @@   -> Var x   -> Expr y   -> IndigoState inp inp-updateVar nextRef action vr e = withObjectState vr updateVarImpl+updateVar nextRef action vr e =+  stmtHookState ("updateVar " <> pretty vr <> " with expr " <> pretty e) $+    withObjectState vr updateVarImpl   where     updateVarImpl (Cell refId) = IndigoState $ \md ->       usingIndigoState md $ unaryOpFlat e $ varActionUpdate refId (mdStack md) action

@@ -6,20 +6,27 @@ -- including plain Indigo code, as well as Indigo contracts.  module Indigo.Compilation-  ( compileIndigo+  ( CommentSettings (..)+  , CommentsVerbosity (..)+  , defaultCommentSettings+  , compileIndigo+  , compileIndigoContractFull   , compileIndigoContract   ) where  import qualified Data.Map as M+import Prelude  import Indigo.Compilation.Field+import Indigo.Compilation.Hooks+  (CommentHooks(..), CommentSettings(..), CommentsVerbosity(..), defaultCommentSettings,+  settingsToHooks) import Indigo.Compilation.Lambda import Indigo.Compilation.Params import Indigo.Compilation.Sequential import Indigo.Frontend.Program (IndigoContract)-import Indigo.Internal hiding (SetField, (>>))+import Indigo.Internal hiding (SetField, (<>), (==), (>>)) import Indigo.Lorentz-import Indigo.Prelude import qualified Lorentz.Instr as L import qualified Lorentz.Macro as L @@ -30,51 +37,61 @@ -- the input stack in inverse order (see 'IndigoWithParams'). compileIndigoImpl   :: forall n inp a. (AreIndigoParams n inp, KnownValue a, Default (StackVars inp))-  => IndigoWithParams n inp a-  -> (StackVars inp -> (Block, RefId) -> (inp :-> inp))+  => SequentialHooks+  -> IndigoWithParams n inp a+  -> ((Block, RefId) -> StackVars inp -> (inp :-> inp))   -> inp :-> inp-compileIndigoImpl paramCode runner =-    runner initMd optimized+compileIndigoImpl seqHooks paramCode runner =+    runner optimized initMd   where     (code, initMd, nextRef) = fromIndigoWithParams @n @a paramCode-    optimized = indigoMtoSequential nextRef code+    optimized = indigoMtoSequential nextRef seqHooks code       & compileLambdas       & optimizeFields --- | Specialiasation of 'compileIndigoImpl' without var decompositions.+-- | Specialization of 'compileIndigoImpl' without var decompositions.+compileIndigoFull+  :: forall n inp a. (AreIndigoParams n inp, KnownValue a, Default (StackVars inp))+  => CommentSettings+  -> IndigoWithParams n inp a+  -> inp :-> inp+compileIndigoFull (settingsToHooks -> CommentHooks{..}) paramCode =+  compileIndigoImpl @n @inp @a chFrontendHooks paramCode $+    \block stk -> sequentialToLorentz (MetaData stk mempty chBackendHooks) block++-- | Simplified version of 'compileIndigoFull' compileIndigo   :: forall n inp a. (AreIndigoParams n inp, KnownValue a, Default (StackVars inp))   => IndigoWithParams n inp a   -> inp :-> inp-compileIndigo paramCode =-  compileIndigoImpl @n @inp @a paramCode (\stk block -> sequentialToLorentz (MetaData stk mempty) block)+compileIndigo = compileIndigoFull @n @inp @a (defaultCommentSettings NoComments)  -- | Compile Indigo code to Lorentz contract. -- Drop elements from the stack to return only @[Operation]@ and @storage@.-compileIndigoContract+compileIndigoContractFull   :: forall param st .   ( KnownValue param   , IsObject st   )-  => IndigoContract param st+  => CommentSettings+  -> IndigoContract param st   -> ContractCode param st-compileIndigoContract code =-  prepare $ compileIndigoImpl @3 @'[param, st, Ops] (contractToIndigoWithParams code) $-    \(parRef :& storageRef :& opsStack) (block, nextRef) ->-      let stRef = case storageRef of-                    NoRef -> error "Storage variable hasn't been assigned"-                    Ref r -> r in-      -- during code Indigo code compilation the stack will look like:-      -- [var_10, var_9, ... , var_3, param_var_2, storage_field_11, storage_field_12, ..., storage_field_20, ops_var_0]-      -- var_1 will represent storage and passed to DecomposedObjects-      let (storageObj, nextRef', someGen) = deepDecomposeCompose nextRef (NoRef :& opsStack) in-      case someGen of-        SomeGenCode (GenCode decompStk decompose composeBack) ->-          let md = MetaData (parRef :& decompStk) $ M.singleton stRef (SomeObject storageObj)-              indigoCode = sequentialToLorentz md (block, nextRef') in-          L.dip decompose # -- decompose storage-          indigoCode # -- run indigo code-          L.dip composeBack+compileIndigoContractFull (settingsToHooks -> CommentHooks{..}) code =+  prepare $ compileIndigoImpl @3 @'[param, st, Ops] chFrontendHooks (contractToIndigoWithParams code) $ \(block, nextRef) ->+    \case+      (StkElements (Ref parRef :& Ref stRef :& opsStack))  ->+        -- during code Indigo code compilation the stack will look like:+        -- [var_10, var_9, ... , var_3, param_var_2, storage_field_11, storage_field_12, ..., storage_field_20, ops_var_0]+        -- var_1 will represent storage and passed to DecomposedObjects+        let (storageObj, nextRef', someGen) = deepDecomposeCompose nextRef (pushNoRef $ StkElements opsStack) in+        case someGen of+          SomeGenCode (GenCode decompStk decompose composeBack) ->+            let md = MetaData (pushRef (Var parRef) decompStk) (M.singleton stRef (SomeObject storageObj)) chBackendHooks+                indigoCode = sequentialToLorentz md (block, nextRef') in+            L.dip decompose # -- decompose storage+            indigoCode # -- run indigo code+            L.dip composeBack+      _ -> error "invalid initial stack during contract compilation"   where     prepare :: ('[param, st, Ops] :-> '[param, st, Ops]) -> ('[(param, st)] :-> '[(Ops, st)])     prepare cd =@@ -82,3 +99,13 @@       cd #       L.drop # -- drop param       L.swap # L.pair++-- | Simplified version of 'compileIndigoContractFull'+compileIndigoContract+  :: forall param st .+  ( KnownValue param+  , IsObject st+  )+  => IndigoContract param st+  -> ContractCode param st+compileIndigoContract = compileIndigoContractFull (defaultCommentSettings NoComments)

@@ -0,0 +1,129 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE NoRebindableSyntax #-}++module Indigo.Compilation.Hooks+  ( CommentsVerbosity (..)+  , CommentSettings (..)+  , defaultCommentSettings+  , CommentHooks (..)+  , settingsToHooks+  ) where++import Lens.Micro.TH (makeLensesFor)+import Prelude++import GHC.Stack.Types (SrcLoc(..))+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++---------------------------------------------+--- Comments settings+---------------------------------------------++data CommentSettings = CommentSettings+  { csVerbosity           :: CommentsVerbosity+  , csPrintFullStackTrace :: Bool+  , csPrintFileName       :: Bool+  } deriving stock (Eq, Show)++defaultCommentSettings :: CommentsVerbosity -> CommentSettings+defaultCommentSettings verb = CommentSettings verb False False++data CommentsVerbosity+  = NoComments+  | LogTopLevelFrontendStatements+  | LogBackendStatements+  | LogAuxCode+  | LogExpressionsComputations+  deriving stock (Show, Eq, Ord, Bounded, Enum)++instance Default CommentSettings where+  def = CommentSettings NoComments False False++makeLensesFor [ ("csVerbosity", "verbosityL")] ''CommentSettings++---------------------------------------------+--- Comments actions+---------------------------------------------++data CommentHooks = CommentHooks+  { chFrontendHooks :: SequentialHooks+  , chBackendHooks  :: GenCodeHooks+  }++instance Semigroup CommentHooks where+  CommentHooks f b <> CommentHooks f1 b1 = CommentHooks (f <> f1) (b <> b1)++instance Monoid CommentHooks where+  mempty = CommentHooks mempty mempty++makeLensesFor [ ("chFrontendHooks", "frontendHooksL")+              , ("chBackendHooks", "backendHooksL")]+              ''CommentHooks++-- | Basically copy-pasted version of 'prettyCallStack' with fixed 'prettySrcLoc'.+prettyFrontendCallStack :: Bool -> Bool -> (String, String) -> CallStack -> ([Text], Text)+prettyFrontendCallStack printFullStk fileName (strt, ends) cs = case getCallStack cs of+    (fn, loc) : rest ->+      ( prettyTop (fn ++ " " ++ strt, loc) :+        if printFullStk && not (null rest) then+          ("Full stacktrace for " <> fromString fn <> ": ") :+          zipWith (\i c -> fromString $ replicate (i * indentSpaces) ' ' ++ prettyCallSite c)+                  [1..] rest+        else []+      , prettyTop (fn ++ " " ++ ends, loc)+      )+    [] -> error "empty call stack in prettyFrontendCallStack"+  where+    prettyTop (fn, loc) = fromString $ prettyCallSite (fn, loc)++    indentSpaces = 2+    prettyCallSite (f, loc) = f ++ " (called at " ++ prettySrcLoc' loc ++ ")"++    prettySrcLoc' :: SrcLoc -> String+    prettySrcLoc' SrcLoc {..} = concat $+      [ srcLocModule, ":", show srcLocStartLine, ":", show srcLocStartCol]+      ++ if fileName then [" in ", srcLocFile] else []++-- | Convert from enum-based verbosity description to specific actions.+settingsToHooks :: CommentSettings -> CommentHooks+settingsToHooks (CommentSettings NoComments _ _) = mempty+settingsToHooks c@(CommentSettings LogTopLevelFrontendStatements p f) = settingsToHooks (c & verbosityL .~ NoComments)+  & frontendHooksL . stmtHookL .~ \cs blk -> do+      let (stCallStk, en) = prettyFrontendCallStack p f ("[fr-stmt starts]", "[fr-stmt ends]") cs+      modify $ \iColl -> iColl {instrList = Comment en : reverse blk ++ map Comment (reverse stCallStk) ++ instrList iColl}+settingsToHooks c@(CommentSettings LogBackendStatements _ _) = settingsToHooks (c & verbosityL .~ LogTopLevelFrontendStatements) &+  -- There was needed some extra hussle to define lenses for GenCodeHooks so I forwent this idea.+  backendHooksL %~ \bh -> bh+    {gchStmtHook = \t cd ->+        L.comment (M.JustComment $ t <> " [bk-stmt starts]") #+        cd #+        L.comment (M.JustComment $ t <> " [bk-stmt ends]")+    }+settingsToHooks c@(CommentSettings LogAuxCode _ _) = settingsToHooks (c & verbosityL .~ LogBackendStatements) &+  backendHooksL %~ \bh -> bh+    { gchAuxiliaryHook = \t cd ->+     let commInstr = L.comment (M.JustComment $ t <> " [bk-aux starts]") in+     -- Compile the passed code with default optimisation settings+     let resLorBlock = compileLorentz cd in+     -- Check if after an optimisation we get empty code block+     -- then omit comment instruction to make it less noisy+     if (M.instrToOps resLorBlock == M.instrToOps M.Nop)+     then cd+     else commInstr # cd+    }+settingsToHooks c@(CommentSettings LogExpressionsComputations _ _) = settingsToHooks (c & verbosityL .~ LogAuxCode) &+  backendHooksL %~ \bh -> bh+    { gchExprHook = \expr cd ->+        L.comment (M.JustComment $ expr <> " [bk-expr starts]") #+        cd #+        L.comment (M.JustComment $ expr <> " [bk-expr ends]")+    }

@@ -7,12 +7,12 @@   ) where  import Prelude+ import qualified Data.Map as M  import Indigo.Backend as B import Indigo.Compilation.Sequential import Indigo.Internal.Var-import Indigo.Lorentz  -- | Collects named lambdas that are used more than once and separates them into -- a lambda creation and multiple lambda executions.@@ -53,6 +53,7 @@     updateBlock' = map $ \case       -- Instructions not concerned, will be kept the same       LiftIndigoState sis -> LiftIndigoState sis+      Comment txt         -> Comment txt       AssignVar vx ex -> AssignVar vx ex       SetVar vx ex -> SetVar vx ex       VarModification upd vx ey -> VarModification upd vx ey@@ -160,6 +161,7 @@        -- Instructions without deeper code block       LiftIndigoState {} -> return ()+      Comment {}         -> return ()       AssignVar {}       -> return ()       SetVar {}          -> return ()       VarModification {} -> return ()@@ -189,7 +191,7 @@        , ldName    :: String        , ldBody    :: Block        , ldArgVar  :: Var arg-       , ldStack   :: StackVars (arg & extra)+       , ldStack   :: StackVars (arg : extra)        } -> Lambda1Def  instance Eq Lambda1Def where

@@ -23,6 +23,9 @@   , CaseBranch (..)    -- * Translations+  , SequentialHooks (..)+  , stmtHookL+  , InstrCollector (..)   , indigoMtoSequential   , sequentialToLorentz @@ -31,24 +34,27 @@   , mapMClauses   ) where -import Util.TypeLits (AppendSymbol)+import Prelude+ 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 Prelude+import Indigo.Backend import Indigo.Frontend.Program import qualified Indigo.Frontend.Statement as S-import Indigo.Lorentz-import Indigo.Internal (HasField, Expr)-import Indigo.Internal.SIS-import Indigo.Internal.Var+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.Backend+import Indigo.Internal.Var+import Indigo.Lorentz+import qualified Michelson.Typed as MT  -- | Simple synonym for a list of 'Instruction' type Block = [Instruction]@@ -64,6 +70,7 @@ -- 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@@ -99,7 +106,7 @@    CreateLambda1     :: CreateLambda1CGeneric extra arg ret-    => StackVars (arg & extra)+    => 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)@@ -332,34 +339,51 @@  -- | Data type internally used to collect 'Instruction's from 'IndigoM' data InstrCollector = InstrCollector-  { nextRef :: RefId+  { 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. indigoMtoSequential   :: RefId+  -> SequentialHooks   -> IndigoM a   -> (Block, RefId)-indigoMtoSequential refId code =-  let InstrCollector {..} = snd $ instrCollect refId code+indigoMtoSequential refId hook code =+  let InstrCollector {..} = snd $ instrCollect refId hook code   in (instrList, nextRef)  -- | Collects instructions starting from an 'IndigoM'. -- Returns an 'InstrCollector' as well as the return value for that 'IndigoM'.-instrCollect :: RefId -> IndigoM a -> (a, InstrCollector)-instrCollect ref (IndigoM imCode) =-  let instrColl = InstrCollector ref []-      (res, resColl) = runState (interpretProgram collectStatement imCode) instrColl-  in (res, InstrCollector (nextRef resColl) (reverse $ instrList resColl))+instrCollect :: RefId -> SequentialHooks -> IndigoM a -> (a, InstrCollector)+instrCollect ref hooks (IndigoM imCode) =+  let instrColl = InstrCollector ref [] hooks+      (res, resColl) = usingState instrColl $ interpretProgram collectStatement imCode+  in (res, InstrCollector (nextRef resColl) (reverse $ instrList resColl) hooks)  -- | Collects instructions starting from 'S.StatementF'. -- IMPORTANT: the instructions are collected in the opposite order (as a stack). collectStatement :: S.StatementF IndigoM a -> State InstrCollector a collectStatement = \case   S.LiftIndigoState is -> appendNewInstr $ LiftIndigoState is+  S.CalledFrom callStk iM -> do+    InstrCollector nRef _prevInstrs hooks <- get+    let (res, inner) = instrCollect nRef hooks iM+    modify $ \s -> s {nextRef = nextRef inner}+    res <$ shStmtHook hooks callStk (instrList inner)   S.NewVar ex -> do     var <- mkNextVar     appendNewInstr $ AssignVar var ex@@ -483,7 +507,7 @@ collectInner :: IndigoM ret -> State InstrCollector (ret, Block) collectInner iM = do   iColl <- get-  let (ret, InstrCollector newRef block) = instrCollect (nextRef iColl) iM+  let (ret, InstrCollector newRef block _) = instrCollect (nextRef iColl) (seqHooks iColl) iM   put $ iColl {nextRef = newRef}   return (ret, block) @@ -502,6 +526,9 @@ 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@@ -527,6 +554,7 @@ instrToSIS :: RefId -> Instruction -> SomeIndigoState inp instrToSIS nextRef = \case   LiftIndigoState sis -> sis+  Comment txt -> toSIS $ comment $ MT.JustComment txt   AssignVar vx ex -> toSIS $ assignVar vx ex   SetVar vx ex -> toSIS $ setVar nextRef vx ex   VarModification upd vx ey -> toSIS $ updateVar nextRef upd vx ey@@ -667,3 +695,5 @@ mapMClauses f (x :& xs) = case x of   OneFieldIndigoSeqCaseClause _cName (CaseBranch _ block _) ->     f block >> mapMClauses f xs++makeLensesFor [ ("shStmtHook", "stmtHookL")] ''SequentialHooks

@@ -116,6 +116,11 @@   , liftIndigoState   ) where +import Fmt (Buildable)+import GHC.Stack (popCallStack)+import GHC.Stack.Types (SrcLoc(..))++import Prelude ((==)) import qualified Indigo.Backend as B import Indigo.Backend.Case hiding (caseRec, entryCaseRec) import Indigo.Backend.Lambda@@ -123,7 +128,7 @@ import Indigo.Compilation (compileIndigoContract) import Indigo.Frontend.Program import Indigo.Frontend.Statement-import Indigo.Internal hiding (SetField, (>>))+import Indigo.Internal hiding (SetField, (>>), (==)) import Indigo.Lorentz import Indigo.Prelude import Lorentz.Entrypoints.Helpers (RequireSumType)@@ -139,6 +144,18 @@ oneIndigoM :: StatementF IndigoM a -> IndigoM a oneIndigoM st = IndigoM (Instr st) +calledFrom :: HasCallStack => IndigoM a -> IndigoM a+calledFrom iM = case getCallStack callStack of+  [] -> error "impossible: calledFrom has HasCallStack constraint, so at least one element has to be at the callStack"+  ((_, loc):_)+    | srcLocModule loc == "Indigo.Frontend.Language" ->+        IndigoM . Instr . CalledFrom (popCallStack callStack) $ iM+    | otherwise -> error $ fromString $+                    "Misuse of calledFrom: the call made from " ++ srcLocModule loc ++ ". " +++                    "You've either forgotten to specify HasCallStack constraint for exported Indigo frontend function or " +++                    "exported calledFrom and called outside of Indigo.Frontend.Language module. " +++                    "Please, report this issue to Indigo developers."+ liftIndigoState :: (forall inp. SomeIndigoState inp) -> IndigoM () liftIndigoState code = IndigoM (Instr $ LiftIndigoState code) @@ -152,73 +169,82 @@ ----------------------------------------------------------------------------  -- | Create a new variable with the result of the given expression as its initial value.-new :: IsExpr ex x => ex -> IndigoM (Var x)-new = oneIndigoM . NewVar . toExpr+new :: (IsExpr ex x, HasCallStack) => ex -> IndigoM (Var x)+new = calledFrom . oneIndigoM . NewVar . toExpr  -- | Set the given variable to the result of the given expression.-setVar :: IsExpr ex x => Var x -> ex -> IndigoM ()-setVar v = oneIndigoM . SetVar v . toExpr+setVar :: (IsExpr ex x, HasCallStack) => Var x -> ex -> IndigoM ()+setVar v = calledFrom . oneIndigoM . SetVar v . toExpr  infixr 0 =:-(=:) :: IsExpr ex x => Var x -> ex -> IndigoM ()-v =: e = setVar v e+(=:) :: (IsExpr ex x, HasCallStack) => Var x -> ex -> IndigoM ()+v =: e = calledFrom $ setVar v e  setField   :: ( ex :~> ftype      , IsObject dt      , IsObject ftype      , HasField dt fname ftype+     , HasCallStack      )   => Var dt -> Label fname -> ex -> IndigoM ()-setField v fName = oneIndigoM . SetField v fName . toExpr+setField v fName = calledFrom . oneIndigoM . SetField v fName . toExpr  (+=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Add n m, ArithResHs M.Add n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(+=) = varModification L.add+(+=) = calledFrom ... varModification L.add  (-=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Sub n m, ArithResHs M.Sub n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(-=) = varModification L.sub+(-=) = calledFrom ... varModification L.sub  (*=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Mul n m, ArithResHs M.Mul n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(*=) = varModification L.mul+(*=) = calledFrom ... varModification L.mul  (||=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Or n m, ArithResHs M.Or n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(||=) = varModification L.or+(||=) = calledFrom ... varModification L.or  (&&=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.And n m, ArithResHs M.And n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(&&=) = varModification L.and+(&&=) = calledFrom ... varModification L.and  (^=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Xor n m, ArithResHs M.Xor n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(^=) = varModification L.xor+(^=) = calledFrom ... varModification L.xor  (<<<=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Lsl n m, ArithResHs M.Lsl n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(<<<=) = varModification L.lsl+(<<<=) = calledFrom ... varModification L.lsl  (>>>=)   :: ( IsExpr ex1 n, IsObject m      , ArithOpHs M.Lsr n m, ArithResHs M.Lsr n m ~ m+     , HasCallStack      ) => Var m -> ex1 -> IndigoM ()-(>>>=) = varModification L.lsr+(>>>=) = calledFrom ... varModification L.lsr  ---------------------------------------------------------------------------- -- Storage Fields@@ -232,9 +258,10 @@      , IsObject store      , IsObject ftype      , HasField store name ftype+     , HasCallStack      )   => Label name -> ex -> IndigoM ()-setStorageField field expr = setField (storageVar @store) field expr+setStorageField field expr = calledFrom $ setField (storageVar @store) field expr  -- | Updates a storage field by using an updating 'IndigoM'. updateStorageField@@ -244,11 +271,12 @@      , HasField store fname ftype      , IsObject store      , IsObject ftype+     , HasCallStack      )   => Label fname   -> (Var ftype -> IndigoM fex)   -> IndigoM ()-updateStorageField field upd = scope $ do+updateStorageField field upd = calledFrom $ scope $ do   let storage = storageVar @store   fieldVar <- new$ storage #! field   expr <- upd fieldVar@@ -261,45 +289,46 @@   :: forall store ftype fname .      ( HasStorage store      , HasField store fname ftype+     , HasCallStack      )   => Label fname -> IndigoM (Var ftype)-getStorageField field = new$ storageVar @store #! field+getStorageField field = calledFrom $ new$ storageVar @store #! field  ---------------------------------------------------------------------------- -- Conditional ----------------------------------------------------------------------------  if_-  :: forall a b ex . (IfConstraint a b, ex :~> Bool)+  :: forall a b ex . (IfConstraint a b, ex :~> Bool, HasCallStack)   => ex   -> IndigoM a   -> IndigoM b   -> IndigoM (RetVars a)-if_ ex tb fb = oneIndigoM $ If (toExpr ex) tb fb+if_ ex tb fb = calledFrom $ oneIndigoM $ If (toExpr ex) tb fb  -- | Run the instruction when the condition is met, do nothing otherwise.-when :: (exc :~> Bool) => exc -> IndigoM () -> IndigoM ()-when cond expr = if_ cond expr (return ())+when :: (exc :~> Bool, HasCallStack) => exc -> IndigoM () -> IndigoM ()+when cond expr = calledFrom $ if_ cond expr (return ())  -- | Reverse of 'when'.-unless :: (exc :~> Bool) => exc -> IndigoM () -> IndigoM ()-unless cond expr = if_ cond (return ()) expr+unless :: (exc :~> Bool, HasCallStack) => exc -> IndigoM () -> IndigoM ()+unless cond expr = calledFrom $ if_ cond (return ()) expr  ifSome-  :: forall x a b ex . (KnownValue x, ex :~> Maybe x, IfConstraint a b)+  :: forall x a b ex . (KnownValue x, ex :~> Maybe x, IfConstraint a b, HasCallStack)   => ex   -> (Var x -> IndigoM a)   -> IndigoM b   -> IndigoM (RetVars a)-ifSome ex tb fb = oneIndigoM $ IfSome (toExpr ex) tb fb+ifSome ex tb fb = calledFrom $ oneIndigoM $ IfSome (toExpr ex) tb fb  ifNone-  :: forall x a b ex . (KnownValue x, ex :~> Maybe x, IfConstraint a b)+  :: forall x a b ex . (KnownValue x, ex :~> Maybe x, IfConstraint a b, HasCallStack)   => ex   -> IndigoM b   -> (Var x -> IndigoM a)   -> IndigoM (RetVars a)-ifNone ex fb tb = ifSome (toExpr ex) tb fb+ifNone ex fb tb = calledFrom $ ifSome (toExpr ex) tb fb  -- | Run the instruction when the given expression returns 'Just' a value, -- do nothing otherwise.@@ -307,11 +336,12 @@   :: forall x exa .      ( KnownValue x      , exa :~> Maybe x+     , HasCallStack      )   => exa   -> (Var x -> IndigoM ())   -> IndigoM ()-whenSome c f = ifSome c f (return ())+whenSome c f = calledFrom $ ifSome c f (return ())  -- | Run the instruction when the given expression returns 'Nothing', -- do nothing otherwise.@@ -319,11 +349,12 @@   :: forall x exa .      ( KnownValue x      , exa :~> Maybe x+     , HasCallStack      )   => exa   -> IndigoM ()   -> IndigoM ()-whenNone c f = ifSome c (\_ -> return ()) f+whenNone c f = calledFrom $ ifSome c (\_ -> return ()) f  ifRight   :: forall x y a b ex .@@ -331,12 +362,13 @@      , KnownValue y      , ex :~> Either y x      , IfConstraint a b+     , HasCallStack      )   => ex   -> (Var x -> IndigoM a)   -> (Var y -> IndigoM b)   -> IndigoM (RetVars a)-ifRight ex rb lb = oneIndigoM $ IfRight (toExpr ex) rb lb+ifRight ex rb lb = calledFrom $ oneIndigoM $ IfRight (toExpr ex) rb lb  ifLeft   :: forall x y a b ex .@@ -344,42 +376,45 @@      , KnownValue y      , ex :~> Either y x      , IfConstraint a b+     , HasCallStack      )   => ex   -> (Var y -> IndigoM b)   -> (Var x -> IndigoM a)   -> IndigoM (RetVars a)-ifLeft ex lb rb = ifRight ex rb lb+ifLeft ex lb rb = calledFrom $ ifRight ex rb lb  whenRight   :: forall x y ex .      ( KnownValue x      , KnownValue y      , ex :~> Either y x+     , HasCallStack      )   => ex   -> (Var x -> IndigoM ())   -> IndigoM ()-whenRight c f = ifRight c f (\_ -> return ())+whenRight c f = calledFrom $ ifRight c f (\_ -> return ())  whenLeft   :: forall x y ex .      ( KnownValue x      , KnownValue y      , ex :~> Either y x+     , HasCallStack      )   => ex   -> (Var y -> IndigoM ())   -> IndigoM ()-whenLeft c f = ifRight c (\_ -> return ()) f+whenLeft c f = calledFrom $ ifRight c (\_ -> return ()) f  ifCons-  :: forall x a b ex . (KnownValue x, ex :~> List x, IfConstraint a b)+  :: forall x a b ex . (KnownValue x, ex :~> List x, IfConstraint a b, HasCallStack)   => ex   -> (Var x -> Var (List x) -> IndigoM a)   -> IndigoM b   -> IndigoM (RetVars a)-ifCons ex tb fb = oneIndigoM $ IfCons (toExpr ex) tb fb+ifCons ex tb fb = calledFrom $ oneIndigoM $ IfCons (toExpr ex) tb fb  ---------------------------------------------------------------------------- -- Case@@ -390,11 +425,12 @@   :: forall dt guard ret clauses .      ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses      , guard :~> dt+     , HasCallStack      )   => guard   -> clauses   -> IndigoM (RetVars ret)-caseRec g = oneIndigoM . Case (toExpr g)+caseRec g = calledFrom . oneIndigoM . Case (toExpr g)  -- | 'caseRec' for tuples. case_@@ -402,11 +438,12 @@      ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses      , RecFromTuple clauses      , guard :~> dt+     , HasCallStack      )   => guard   -> IsoRecTuple clauses   -> IndigoM (RetVars ret)-case_ g = caseRec (toExpr g) . recFromTuple @clauses+case_ g = calledFrom . caseRec (toExpr g) . recFromTuple @clauses   -- | 'caseRec' for pattern-matching on parameter.@@ -415,12 +452,13 @@      ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses      , DocumentEntrypoints entrypointKind dt      , guard :~> dt+     , HasCallStack      )   => Proxy entrypointKind   -> guard   -> clauses   -> IndigoM (RetVars ret)-entryCaseRec proxy g cls = oneIndigoM $ EntryCase proxy (toExpr g) cls+entryCaseRec proxy g cls = calledFrom . oneIndigoM $ EntryCase proxy (toExpr g) cls  -- | 'entryCaseRec' for tuples. entryCase@@ -429,12 +467,13 @@      , RecFromTuple clauses      , DocumentEntrypoints entrypointKind dt      , guard :~> dt+     , HasCallStack      )   => Proxy entrypointKind   -> guard   -> IsoRecTuple clauses   -> IndigoM (RetVars ret)-entryCase proxy g = entryCaseRec proxy g . recFromTuple @clauses+entryCase proxy g = calledFrom . entryCaseRec proxy g . recFromTuple @clauses  entryCaseSimple   :: forall cp guard ret clauses .@@ -444,11 +483,12 @@      , NiceParameterFull cp      , RequireFlatParamEps cp      , guard :~> cp+     , HasCallStack      )   => guard   -> IsoRecTuple clauses   -> IndigoM (RetVars ret)-entryCaseSimple g = oneIndigoM . EntryCaseSimple (toExpr g) . recFromTuple @clauses+entryCaseSimple g = calledFrom . oneIndigoM . EntryCaseSimple (toExpr g) . recFromTuple @clauses  {-# DEPRECATED (//->) "use '#=' instead" #-} -- | An alias for '#=' kept only for backward compatibility.@@ -501,17 +541,17 @@ type IndigoEntrypoint param = param -> IndigoProcedure  scope-  :: forall a . ScopeCodeGen a+  :: forall a . (ScopeCodeGen a, HasCallStack)   => IndigoM a   -> IndigoFunction a-scope = oneIndigoM . Scope+scope = calledFrom . oneIndigoM . Scope  -- | Alias for 'scope' we use in the tutorial. defFunction-  :: forall a . ScopeCodeGen a+  :: forall a . (ScopeCodeGen a, HasCallStack)   => IndigoM a   -> IndigoFunction a-defFunction = scope+defFunction = calledFrom . scope  -- | A more specific version of 'defFunction' meant to more easily create -- 'IndigoContract's.@@ -519,9 +559,10 @@ -- Used in the tutorial. The 'HasSideEffects' constraint is -- specified to avoid the warning for redundant constraints. defContract-  :: (HasSideEffects => IndigoM ())+  :: HasCallStack+  => (HasSideEffects => IndigoM ())   -> (HasSideEffects => IndigoProcedure)-defContract = scope+defContract = calledFrom . scope  -- | Family of @defNamed*LambdaN@ functions put an Indigo computation -- on the stack to later call it avoiding code duplication.@@ -551,12 +592,13 @@   , Typeable res   , ExecuteLambdaEff1C st (ExprType argExpr) res   , CreateLambdaEff1C st (ExprType argExpr) res+  , HasCallStack   )   => String   -> (Var (ExprType argExpr) -> IndigoM res)   -> (argExpr -> IndigoM (RetVars res)) defNamedEffLambda1 lName body = \ex ->-  oneIndigoM $ LambdaCall1 (EffLambda (Proxy @st)) lName body (toExpr ex)+  calledFrom $ oneIndigoM $ LambdaCall1 (EffLambda (Proxy @st)) lName body (toExpr ex)  -- | Like defNamedEffLambda1 but doesn't make side effects. defNamedLambda1@@ -564,24 +606,28 @@   ( ToExpr argExpr   , Typeable res   , ExecuteLambda1C st (ExprType argExpr) res-  , CreateLambda1C st (ExprType argExpr) res)+  , CreateLambda1C st (ExprType argExpr) res+  , HasCallStack+  )   => String   -> (Var (ExprType argExpr) -> IndigoM res)   -> (argExpr -> IndigoM (RetVars res)) defNamedLambda1 lName body = \ex ->-  oneIndigoM $ LambdaCall1 (StorageLambda (Proxy @st)) lName body (toExpr ex)+  calledFrom $ oneIndigoM $ LambdaCall1 (StorageLambda (Proxy @st)) lName body (toExpr ex)  -- | Like defNamedLambda1 but doesn't take an argument. defNamedLambda0   :: forall st res .   ( Typeable res   , ExecuteLambda1C st () res-  , CreateLambda1C st () res)+  , CreateLambda1C st () res+  , HasCallStack+  )   => String   -> IndigoM res   -> IndigoM (RetVars res) defNamedLambda0 lName body =-  oneIndigoM $ LambdaCall1 (StorageLambda (Proxy @st)) lName (\(_ :: Var ()) -> body) (C ())+  calledFrom $ oneIndigoM $ LambdaCall1 (StorageLambda (Proxy @st)) lName (\(_ :: Var ()) -> body) (C ())  -- | Like defNamedEffLambda1 but doesn't modify storage and doesn't make side effects. defNamedPureLambda1@@ -589,68 +635,71 @@   ( ToExpr argExpr   , Typeable res   , ExecuteLambdaPure1C (ExprType argExpr) res-  , CreateLambdaPure1C (ExprType argExpr) res)+  , CreateLambdaPure1C (ExprType argExpr) res+  , HasCallStack+  )   => String   -> (Var (ExprType argExpr) -> IndigoM res)   -> (argExpr -> IndigoM (RetVars res)) defNamedPureLambda1 lName body = \ex ->-  oneIndigoM $ LambdaCall1 PureLambda lName body (toExpr ex)+  calledFrom $ oneIndigoM $ LambdaCall1 PureLambda lName body (toExpr ex)  ---------------------------------------------------------------------------- -- Loop ----------------------------------------------------------------------------  -- | While statement.-while :: forall ex . ex :~> Bool => ex -> IndigoM () -> IndigoM ()-while e body = oneIndigoM $ While (toExpr e) body+while :: forall ex . (ex :~> Bool, HasCallStack) => ex -> IndigoM () -> IndigoM ()+while e body = calledFrom $ oneIndigoM $ While (toExpr e) body  whileLeft   :: forall x y ex .      ( ex :~> Either y x      , KnownValue y      , KnownValue x+     , HasCallStack      )   => ex   -> (Var y -> IndigoM ())   -> IndigoM (Var x)-whileLeft e body = oneIndigoM $ WhileLeft (toExpr e) body+whileLeft e body = calledFrom $ oneIndigoM $ WhileLeft (toExpr e) body  -- | For statements to iterate over a container. forEach-  :: forall a e . (IterOpHs a, KnownValue (IterOpElHs a), e :~> a)+  :: forall a e . (IterOpHs a, KnownValue (IterOpElHs a), e :~> a, HasCallStack)   => e -> (Var (IterOpElHs a) -> IndigoM ())   -> IndigoM ()-forEach container body = oneIndigoM $ ForEach (toExpr container) body+forEach container body = calledFrom $ oneIndigoM $ ForEach (toExpr container) body  ---------------------------------------------------------------------------- -- Documentation ----------------------------------------------------------------------------  -- | Put a document item.-doc :: DocItem di => di -> IndigoM ()-doc di = liftIndigoState $ toSIS $ B.doc di+doc :: (DocItem di, HasCallStack) => di -> IndigoM ()+doc di = calledFrom $ liftIndigoState $ toSIS $ B.doc di  -- | Group documentation built in the given piece of code -- into a block dedicated to one thing, e.g. to one entrypoint.-docGroup :: DocGrouping -> IndigoM () -> IndigoM ()-docGroup = oneIndigoM ... DocGroup+docGroup :: HasCallStack => DocGrouping -> IndigoM () -> IndigoM ()+docGroup = calledFrom . oneIndigoM ... DocGroup  -- | Insert documentation of the contract's storage type. The type -- should be passed using type applications.-docStorage :: forall storage. TypeHasDoc storage => IndigoM ()-docStorage = liftIndigoState $ toSIS $ B.docStorage @storage+docStorage :: forall storage. (TypeHasDoc storage, HasCallStack) => IndigoM ()+docStorage = calledFrom $ liftIndigoState $ toSIS $ B.docStorage @storage  -- | Give a name to the given contract. Apply it to the whole contract code.-contractName :: Text -> IndigoM () -> IndigoM ()-contractName = oneIndigoM ... ContractName+contractName :: HasCallStack => Text -> IndigoM () -> IndigoM ()+contractName = calledFrom . oneIndigoM ... ContractName  -- | Attach general info to the given contract.-contractGeneral :: IndigoM () -> IndigoM ()-contractGeneral = oneIndigoM . ContractGeneral+contractGeneral :: HasCallStack => IndigoM () -> IndigoM ()+contractGeneral = calledFrom . oneIndigoM . ContractGeneral  -- | Attach default general info to the contract documentation.-contractGeneralDefault :: IndigoM ()-contractGeneralDefault = liftIndigoState $ toSIS $ B.contractGeneralDefault+contractGeneralDefault :: HasCallStack => IndigoM ()+contractGeneralDefault = calledFrom $ liftIndigoState $ toSIS $ B.contractGeneralDefault  -- | Indigo version for the homonym Lorentz function. finalizeParamCallingDoc@@ -661,19 +710,19 @@      , HasCallStack      )   => (Var (ExprType param) -> IndigoM ()) -> param -> IndigoM ()-finalizeParamCallingDoc i = oneIndigoM . FinalizeParamCallingDoc i . toExpr+finalizeParamCallingDoc i = calledFrom . oneIndigoM . FinalizeParamCallingDoc i . toExpr  -- | Put a 'DDescription' doc item.-description :: Markdown -> IndigoM ()-description = doc . DDescription+description :: HasCallStack => Markdown -> IndigoM ()+description = calledFrom . doc . DDescription  -- | Put a 'DAnchor' doc item.-anchor :: Text -> IndigoM ()-anchor = doc . DAnchor . toAnchor+anchor :: HasCallStack => Text -> IndigoM ()+anchor = calledFrom . doc . DAnchor . toAnchor  -- | Put a 'DEntrypointExample' doc item.-example :: forall a. NiceParameter a => a -> IndigoM ()-example = doc . mkDEntrypointExample+example :: forall a. (NiceParameter a, HasCallStack) => a -> IndigoM ()+example = calledFrom . doc . mkDEntrypointExample  ---------------------------------------------------------------------------- -- Contract call@@ -683,10 +732,11 @@   :: forall p mname.      ( NiceParameterFull p      , KnownValue (GetEntrypointArgCustom p mname)+     , HasCallStack      )   => EntrypointRef mname   -> IndigoM (Var (ContractRef (GetEntrypointArgCustom p mname)))-selfCalling = oneIndigoM ... SelfCalling (Proxy @p)+selfCalling = calledFrom . oneIndigoM ... SelfCalling (Proxy @p)  contractCalling   :: forall cp epRef epArg addr exAddr.@@ -695,22 +745,29 @@      , ToT addr ~ ToT Address      , exAddr :~> addr      , KnownValue epArg+     , HasCallStack      )   => epRef -> exAddr -> IndigoM (Var (Maybe (ContractRef epArg)))-contractCalling epRef = oneIndigoM . ContractCalling (Proxy @cp) epRef . toExpr+contractCalling epRef = calledFrom . oneIndigoM . ContractCalling (Proxy @cp) epRef . toExpr  ---------------------------------------------------------------------------- -- Side-effects operations ----------------------------------------------------------------------------  transferTokens-  :: (IsExpr exp p, IsExpr exm Mutez, IsExpr exc (ContractRef p), NiceParameter p, HasSideEffects)+  :: ( IsExpr exp p+     , IsExpr exm Mutez+     , IsExpr exc (ContractRef p)+     , NiceParameter p+     , HasSideEffects+     , HasCallStack+     )   => exp -> exm -> exc -> IndigoM ()-transferTokens ep em ec = oneIndigoM $+transferTokens ep em ec = calledFrom $ oneIndigoM $   TransferTokens (toExpr ep) (toExpr em) (toExpr ec) -setDelegate :: (HasSideEffects, IsExpr ex (Maybe KeyHash)) => ex -> IndigoM ()-setDelegate =  oneIndigoM . SetDelegate . toExpr+setDelegate :: (HasSideEffects, IsExpr ex (Maybe KeyHash), HasCallStack) => ex -> IndigoM ()+setDelegate = calledFrom . oneIndigoM . SetDelegate . toExpr  -- | Create contract using default compilation options for Lorentz compiler. --@@ -720,13 +777,16 @@      , IsExpr exk (Maybe KeyHash), IsExpr exm Mutez, IsExpr exs st      , NiceStorage st, NiceParameterFull param      , HasSideEffects+     , HasCallStack      )   => (HasStorage st => Var param -> IndigoM ())   -> exk   -> exm   -> exs   -> IndigoM (Var Address)-createContract iCtr ek em es = oneIndigoM $+createContract iCtr ek em es = calledFrom $ oneIndigoM $+  -- pva701: we don't have GenCodeHooks at this point so we just pass empty ones+  -- Maybe we should pass this hooks via 'given'   CreateContract (defaultContract $ compileIndigoContract iCtr) (toExpr ek) (toExpr em) (toExpr es)  -- | Create contract from raw Lorentz 'L.Contract'.@@ -735,13 +795,14 @@      , IsExpr exk (Maybe KeyHash), IsExpr exm Mutez, IsExpr exs st      , NiceStorage st, NiceParameterFull param      , HasSideEffects+     , HasCallStack      )   => L.Contract param st   -> exk   -> exm   -> exs   -> IndigoM (Var Address)-createLorentzContract lCtr ek em es = oneIndigoM $+createLorentzContract lCtr ek em es = calledFrom $ oneIndigoM $   CreateContract lCtr (toExpr ek) (toExpr em) (toExpr es)  ----------------------------------------------------------------------------@@ -749,14 +810,14 @@ ----------------------------------------------------------------------------  failWith-  :: forall ret a ex . (IsExpr ex a, ReturnableValue ret)+  :: forall ret a ex . (IsExpr ex a, ReturnableValue ret, HasCallStack)   => ex -> IndigoM (RetVars ret)-failWith = oneIndigoM . FailOver (Proxy @ret) (toSIS . B.failWith) . toExpr+failWith = calledFrom . oneIndigoM . FailOver (Proxy @ret) (toSIS . B.failWith) . toExpr  failUsing_-  :: forall ret x. (IsError x, ReturnableValue ret)+  :: forall ret x. (IsError x, Buildable x, ReturnableValue ret, HasCallStack)   => x -> IndigoM (RetVars ret)-failUsing_ x = oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failUsing_ x)+failUsing_ x = calledFrom $ oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failUsing_ x)  failCustom   :: forall ret tag err ex.@@ -765,31 +826,35 @@      , CustomErrorHasDoc tag      , NiceConstant err      , ex :~> err+     , HasCallStack      )   => Label tag -> ex -> IndigoM (RetVars ret)-failCustom l = oneIndigoM . FailOver (Proxy @ret) (toSIS . B.failCustom l) . toExpr+failCustom l = calledFrom . oneIndigoM . FailOver (Proxy @ret) (toSIS . B.failCustom l) . toExpr  failCustom_   :: forall ret tag notVoidErrorMsg.      ( ReturnableValue ret      , RequireNoArgError tag notVoidErrorMsg      , CustomErrorHasDoc tag+     , HasCallStack      )   => Label tag -> IndigoM (RetVars ret)-failCustom_ tag = oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failCustom_ tag)+failCustom_ tag = calledFrom $ oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failCustom_ tag)  failUnexpected_-  :: forall ret. ReturnableValue ret+  :: forall ret. (ReturnableValue ret, HasCallStack)   => MText -> IndigoM (RetVars ret)-failUnexpected_ tx = oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failUnexpected_ tx)+failUnexpected_ tx = calledFrom $ oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failUnexpected_ tx)  assert   :: forall x ex.      ( IsError x+     , Buildable x      , IsExpr ex Bool+     , HasCallStack      )   => x -> ex -> IndigoM ()-assert err ex = if_ ex (return ()) (failUsing_ @() err)+assert err ex = calledFrom $ if_ ex (return ()) (failUsing_ @() err)  assertCustom   :: forall tag err errEx ex .@@ -798,81 +863,91 @@      , NiceConstant err      , IsExpr errEx err      , IsExpr ex Bool+     , HasCallStack      )   => Label tag -> errEx -> ex -> IndigoM ()-assertCustom tag errEx ex = if_ ex (return ()) (failCustom @() tag errEx)+assertCustom tag errEx ex = calledFrom $ if_ ex (return ()) (failCustom @() tag errEx)  assertCustom_   :: forall tag notVoidErrorMsg ex.      ( RequireNoArgError tag notVoidErrorMsg      , CustomErrorHasDoc tag      , IsExpr ex Bool+     , HasCallStack      )   => Label tag -> ex -> IndigoM ()-assertCustom_ tag ex = if_ ex (return ()) (failCustom_ @() tag)+assertCustom_ tag ex = calledFrom $ if_ ex (return ()) (failCustom_ @() tag)  assertSome   :: forall x err ex.   ( IsError err+  , Buildable err   , KnownValue x   , ex :~> Maybe x+  , HasCallStack   )   => err -> ex -> IndigoM ()-assertSome err ex = ifSome ex (\_ -> failUsing_ @() err) (return ())+assertSome err ex = calledFrom $ ifSome ex (\_ -> failUsing_ @() err) (return ())  assertNone   :: forall x err ex.   ( IsError err+  , Buildable err   , KnownValue x   , ex :~> Maybe x+  , HasCallStack   )   => err -> ex -> IndigoM ()-assertNone err ex = ifSome ex (\_ -> return ()) (failUsing_ @() err)+assertNone err ex = calledFrom $ ifSome ex (\_ -> return ()) (failUsing_ @() err)  assertRight   :: forall x y err ex.   ( IsError err+  , Buildable err   , KnownValue x   , KnownValue y   , ex :~> Either y x+  , HasCallStack   )   => err -> ex -> IndigoM ()-assertRight err ex = ifRight ex (\_ -> failUsing_ @() err) (\_ -> return ())+assertRight err ex = calledFrom $ ifRight ex (\_ -> failUsing_ @() err) (\_ -> return ())  assertLeft   :: forall x y err ex.   ( IsError err+  , Buildable err   , KnownValue x   , KnownValue y   , ex :~> Either y x+  , HasCallStack   )   => err -> ex -> IndigoM ()-assertLeft err ex = ifRight ex (\_ -> return ()) (\_ -> failUsing_ @() err)+assertLeft err ex = calledFrom $ ifRight ex (\_ -> return ()) (\_ -> failUsing_ @() err)  ---------------------------------------------------------------------------- -- Comments ----------------------------------------------------------------------------  -- | Add a comment in a generated Michelson code-justComment :: Text -> IndigoM ()-justComment = comment . MT.JustComment+justComment :: HasCallStack => Text -> IndigoM ()+justComment = calledFrom . comment . MT.JustComment  -- | Add a comment in a generated Michelson code-comment :: MT.CommentType -> IndigoM ()-comment t = liftIndigoState $ toSIS (B.comment t)+comment :: HasCallStack => MT.CommentType -> IndigoM ()+comment t = calledFrom $ liftIndigoState $ toSIS (B.comment t)  -- | Add a comment before and after the given Indigo function code. -- The first argument is the name of the function.-commentAroundFun :: Text -> IndigoM a -> IndigoM a-commentAroundFun fName body =+commentAroundFun :: HasCallStack => Text -> IndigoM a -> IndigoM a+commentAroundFun fName body = calledFrom $   comment (MT.FunctionStarts fName) >>   body >>=   \res -> res <$ comment (MT.FunctionEnds fName)  -- | Add a comment before and after the given Indigo statement code. -- The first argument is the name of the statement.-commentAroundStmt :: Text -> IndigoM a -> IndigoM a-commentAroundStmt sName body =+commentAroundStmt :: HasCallStack => Text -> IndigoM a -> IndigoM a+commentAroundStmt sName body = calledFrom $   comment (MT.StatementStarts sName) >>   body >>=   \res -> res <$ comment (MT.StatementEnds sName)

@@ -56,6 +56,16 @@   -- which are not going to be analyzed by optimizer.   LiftIndigoState :: (forall inp. SomeIndigoState inp) -> StatementF freer () +  -- | Constructor wrapper which holds 'IndigoM' function+  -- among with the callstack of caller side.+  --+  -- The another option could be to add `HasCallStack` to 'Instr' constructor of 'Program'+  -- but this would have held only a 'CallStack' of separate primitive statement (unlike 'updateStorageField', etc).+  -- The idea is to be able to have correspondence between original Indigo code+  -- and the generated Michelson assembler and vice versa to perform quick navigation and analyze,+  -- so it's better to have call stack for non-primitive frontend statements.+  CalledFrom :: CallStack -> freer a -> StatementF freer a+   NewVar :: KnownValue x => Expr x -> StatementF freer (Var x)   SetVar :: KnownValue x => Var x -> Expr x -> StatementF freer ()   VarModification

@@ -22,7 +22,7 @@   , ternaryOpFlat   ) where -import Data.Vinyl.Core (RMap (..))+import Data.Vinyl.Core (RMap(..))  import qualified Lorentz.ADT as L import qualified Lorentz.Instr as L@@ -35,19 +35,19 @@ import Indigo.Internal.Field import Indigo.Internal.Lookup (varActionGet) import Indigo.Internal.Object-  (IndigoObjectF (..), NamedFieldObj (..), castFieldConstructors, namedToTypedRec, typedToNamedRec)+  (IndigoObjectF(..), NamedFieldObj(..), castFieldConstructors, namedToTypedRec, typedToNamedRec) import Indigo.Internal.State-  (DecomposedObjects, GenCode (..), IndigoState (..), MetaData (..), replStkMd, usingIndigoState,+  (DecomposedObjects, GenCode(..), IndigoState(..), MetaData(..), replStkMd, usingIndigoState,   withObject, withObjectState)-import Indigo.Internal.Var (Var (..), pushNoRef)+import Indigo.Internal.Var (Var(..), pushNoRef) import Indigo.Lorentz -compileExpr :: forall a inp . Expr a -> IndigoState inp (a & inp)+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 (Sub e1 e2) = binaryOp e1 e2 L.sub compileExpr (Mul e1 e2) = binaryOp e1 e2 L.mul compileExpr (Div e1 e2) = binaryOp e1 e2 (L.ediv # L.ifSome L.car (failUsing [mt|devision by zero|])) compileExpr (Mod e1 e2) = binaryOp e1 e2 (L.ediv # L.ifSome L.cdr (failUsing [mt|devision by zero|]))@@ -82,6 +82,8 @@ 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 e) = unaryOp e L.contract@@ -109,10 +111,10 @@ compileExpr (Unwrap l exDt) = unaryOp exDt $ L.unwrapUnsafe_ l  compileExpr (ObjMan fldAcc) = compileObjectManipulation fldAcc-compileExpr (Construct fields) = IndigoState $ \md ->+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 ->+compileExpr (ConstructWithoutNamed _ fields) = IndigoState $ \md ->   let fieldCtrs =           castFieldConstructors @a $             rmap (fieldCtor . gcCode . usingIndigoState md . compileExpr) fields@@ -152,7 +154,7 @@  -- | 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 :: 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@@ -169,7 +171,7 @@   -> Expr a objToExpr _ (Cell refId) = V (Var @a refId) objToExpr convExpr (Decomposed fields) =-  ConstructWithoutNamed $ namedToTypedRec @a convExpr fields+  ConstructWithoutNamed (Proxy @a) (namedToTypedRec @a convExpr fields)  -- | Compile 'IndigoObjectF' to a stack cell, -- with respect to given function that compiles inner fields.@@ -177,7 +179,7 @@   :: forall a inp f .      (forall name . f name -> Expr (GetFieldType a name))   -> IndigoObjectF f a-  -> IndigoState inp (a & inp)+  -> 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@@ -189,7 +191,7 @@ -- onto stack. data ObjManipulationRes inp a where   StillObject :: ObjectExpr a -> ObjManipulationRes inp a-  OnStack :: IndigoState inp (a & inp) -> 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.@@ -247,9 +249,9 @@       setFieldOnStack compLHS (compileExpr ef) (sopSetField (flSFO $ fieldLens @dt) targetLb)   where     setFieldOnStack-      :: IndigoState inp (dt & inp)-      -> IndigoState (dt & inp) (fld & dt & inp)-      -> fld & dt & inp :-> dt & inp+      :: 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@@ -265,7 +267,7 @@ -- 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) =+exprToManRes _ (ConstructWithoutNamed _ fields) =   StillObject $ Decomposed $ typedToNamedRec @x NamedFieldExpr fields exprToManRes objs (V var) = withObject objs var $ \case   Cell refId ->@@ -283,8 +285,8 @@   => Expr n   -> Expr m   -> Expr l-  -> n & m & l & inp :-> res & inp-  -> IndigoState inp (res & inp)+  -> 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@@ -294,8 +296,8 @@ binaryOp   :: KnownValue res   => Expr n -> Expr m-  -> n & m & inp :-> res & inp-  -> IndigoState inp (res & inp)+  -> 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@@ -304,8 +306,8 @@ unaryOp   :: KnownValue res   => Expr n-  -> n & inp :-> res & inp-  -> IndigoState inp (res & inp)+  -> 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@@ -318,7 +320,7 @@   :: Expr n   -> Expr m   -> Expr l-  -> n & m & l & inp :-> inp+  -> 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@@ -328,7 +330,7 @@  binaryOpFlat   :: Expr n -> Expr m-  -> n & m & inp :-> inp+  -> n : m : inp :-> inp   -> IndigoState inp inp binaryOpFlat e1 e2 opCode = IndigoState $ \md ->   let GenCode st2 cd2 _cl2  = runIndigoState (compileExpr e2) md in@@ -337,7 +339,7 @@  unaryOpFlat   :: Expr n-  -> n & inp :-> inp+  -> n : inp :-> inp   -> IndigoState inp inp unaryOpFlat e opCode = IndigoState $ \md ->   let cd = gcCode $ runIndigoState (compileExpr e) md in

@@ -15,6 +15,7 @@   ) where  import Prelude+ import Data.Constraint (Dict(..)) import Data.Vinyl.TypeLevel @@ -23,8 +24,8 @@ import Indigo.Internal.Lookup import Indigo.Internal.Object import Indigo.Internal.SIS-import Indigo.Internal.Var import Indigo.Internal.State+import Indigo.Internal.Var import Indigo.Lorentz import qualified Lorentz.ADT as L import qualified Lorentz.Instr as L@@ -43,7 +44,7 @@ -- Clean up code of 'SomeIndigoState' composes the value back. deepDecomposeCompose   :: forall a inp . IsObject a-  => SIS' (a & inp) (Object a)+  => SIS' (a : inp) (Object a) deepDecomposeCompose   | Just Dict <- complexObjectDict @a = \refId st ->       let decomposedSt = fst (noRefGenCode @(FieldTypes a) $ popNoRef st) in@@ -57,7 +58,8 @@           }         )   | otherwise =-      \refId stk -> (Cell refId, refId + 1, SomeGenCode $ runIndigoState (assignTopVar $ Var refId) (MetaData stk mempty))+      \refId stk -> (Cell refId, refId + 1, SomeGenCode $+                      usingIndigoState (MetaData stk mempty emptyGenCodeHooks) (assignTopVar $ Var refId) )   where     decomposeComposeFields       :: forall flds . (KnownList flds, AllConstrained IsObject flds)@@ -96,7 +98,7 @@  -- | 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 _ (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@@ -119,7 +121,7 @@ -- wrapped into 'Deconstructed' constructor. deconstructOnStack   :: forall a inp . ComplexObjectC a-  => IndigoState inp (a & inp)+  => IndigoState inp (a : inp)   -> ExprDecomposition inp a deconstructOnStack fetchFld =   Deconstructed $ IndigoState $ \md ->

@@ -45,6 +45,7 @@    -- * Serialization   , pack, unpack+  , packRaw, unpackRaw    -- * Pairs   , pair, car, cdr, fst, snd@@ -105,7 +106,9 @@   , checkSignature   ) where -import Data.Vinyl.Core (RMap (..))+import Data.Constraint ((\\))+import Data.Vinyl.Core (RMap(..), RecordToList (..))+import Fmt (Buildable)  import Indigo.Internal.Expr.Types import Indigo.Internal.Field@@ -122,8 +125,8 @@ -- Basic ---------------------------------------------------------------------------- -constExpr :: NiceConstant a => a -> Expr a-constExpr = C+constExpr :: forall a . NiceConstant a => a -> Expr a+constExpr a = C a \\ niceConstantEvi @a  -- | Create an expression holding a variable. varExpr :: KnownValue a => Var a -> Expr a@@ -319,12 +322,18 @@ -- Serialization ---------------------------------------------------------------------------- -pack :: (ex :~> a, NicePackedValue a) => ex -> Expr ByteString+pack :: (ex :~> a, NicePackedValue a) => ex -> Expr (Packed a) pack = Pack . toExpr -unpack :: (NiceUnpackedValue a, exb :~> ByteString) => exb -> Expr (Maybe a)+unpack :: (NiceUnpackedValue a, exb :~> Packed a) => exb -> Expr (Maybe a) unpack = Unpack . toExpr +packRaw :: (ex :~> a, NicePackedValue a) => ex -> Expr ByteString+packRaw = PackRaw . toExpr++unpackRaw :: (NiceUnpackedValue a, exb :~> ByteString) => exb -> Expr (Maybe a)+unpackRaw = UnpackRaw . toExpr+ ---------------------------------------------------------------------------- -- Pairs ----------------------------------------------------------------------------@@ -577,6 +586,7 @@ stInsertNew, (++@)   :: ( StoreHasSubmap store name key value      , IsError err+     , Buildable err      , exKey   :~> key      , exVal   :~> value      , exStore :~> store@@ -689,20 +699,22 @@ construct   :: ( InstrConstructC dt, KnownValue dt      , RMap (ConstructorFieldTypes dt)+     , RecordToList (ConstructorFieldTypes dt)      , fields ~ Rec Expr (ConstructorFieldTypes dt)      , RecFromTuple fields      )   => IsoRecTuple fields -> Expr dt-construct = Construct . recFromTuple+construct = Construct Proxy. recFromTuple  constructRec   :: ( InstrConstructC dt      , RMap (ConstructorFieldTypes dt)+     , RecordToList (ConstructorFieldTypes dt)      , KnownValue dt      )   => Rec Expr (ConstructorFieldTypes dt)   -> Expr dt-constructRec = Construct+constructRec = Construct Proxy  ---------------------------------------------------------------------------- -- Contract@@ -796,20 +808,21 @@  checkSignature   :: ( pkExpr :~> PublicKey-     , sigExpr :~> Signature-     , hashExpr :~> ByteString+     , sigExpr :~> TSignature bs+     , hashExpr :~> bs+     , BytesLike bs      )   => pkExpr -> sigExpr -> hashExpr   -> Expr Bool checkSignature pk sig hash = CheckSignature (toExpr pk) (toExpr sig) (toExpr hash) -sha256 :: (hashExpr :~> ByteString) => hashExpr -> Expr ByteString+sha256 :: (hashExpr :~> bs, BytesLike bs) => hashExpr -> Expr (Hash Sha256 bs) sha256 = Sha256 . toExpr -sha512 :: (hashExpr :~> ByteString) => hashExpr -> Expr ByteString+sha512 :: (hashExpr :~> bs, BytesLike bs) => hashExpr -> Expr (Hash Sha512 bs) sha512 = Sha512 . toExpr -blake2b :: (hashExpr :~> ByteString) => hashExpr -> Expr ByteString+blake2b :: (hashExpr :~> bs, BytesLike bs) => hashExpr -> Expr (Hash Blake2b bs) blake2b = Blake2b . toExpr  hashKey :: (keyExpr :~> PublicKey) => keyExpr -> Expr KeyHash

@@ -0,0 +1,130 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE QuasiQuotes #-}++module Indigo.Internal.Expr.TH+       ( deriveExprBuildable+       ) where++import qualified Data.Map as M+import qualified Data.Set as S+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import qualified Language.Haskell.TH.Syntax as TH+import Prelude hiding (Const)+import qualified Text.Casing 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 "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 (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]+    ]

@@ -35,17 +35,20 @@   , NamedFieldExpr (..)   ) where +import Prelude hiding (Const (..)) import qualified Data.Kind as Kind-import Data.Vinyl.Core (RMap (..))+import Data.Vinyl.Core (RMap(..), RecordToList(..))+import Data.Vinyl.Functor (Const (..))+import Data.Typeable (typeRep)+import Fmt (Buildable (..), pretty) +import Indigo.Lorentz+import Indigo.Internal.Expr.TH (deriveExprBuildable) import Indigo.Internal.Field import Indigo.Internal.Object (ComplexObjectC, FieldTypes, IndigoObjectF (..)) import Indigo.Internal.Var (Var (..))-import Indigo.Lorentz-import Indigo.Prelude (Either (..), id) import qualified Michelson.Typed.Arith as M-import Michelson.Typed.Haskell.Instr.Product (GetFieldType)-import Michelson.Typed.Haskell.Instr.Sum (CtorOnlyField, InstrUnwrapC, InstrWrapOneC)+import Michelson.Typed (GetFieldType, CtorOnlyField, InstrUnwrapC, InstrWrapOneC)  ---------------------------------------------------------------------------- -- The Expr data type@@ -167,6 +170,7 @@     :: ( StoreHasSubmap store name key value        , KnownValue store        , IsError err+       , Buildable err        )     => Label name -> err     -> Expr key -> Expr value -> Expr store -> Expr store@@ -208,14 +212,15 @@   Construct     :: ( InstrConstructC dt        , RMap (ConstructorFieldTypes dt)+       , RecordToList (ConstructorFieldTypes dt)        , KnownValue dt        )-    => Rec Expr (ConstructorFieldTypes dt) -> Expr dt+    => Proxy dt -> Rec Expr (ConstructorFieldTypes dt) -> Expr dt    -- TODO remove Construct and rename this one   ConstructWithoutNamed     :: ComplexObjectC dt-    => Rec Expr (FieldTypes dt) -> Expr dt+    => Proxy dt -> Rec Expr (FieldTypes dt) -> Expr dt    Name     :: KnownValue (name :! t)@@ -245,10 +250,18 @@    Pack     :: NicePackedValue a-    => Expr a -> Expr ByteString+    => 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)@@ -305,11 +318,12 @@     :: KnownValue (Void_ a b)     => Expr a -> Expr (Lambda b b) -> Expr (Void_ a b) -  CheckSignature :: Expr PublicKey -> Expr Signature -> Expr ByteString -> Expr Bool+  CheckSignature+    :: BytesLike bs => Expr PublicKey -> Expr (TSignature bs) -> Expr bs -> Expr Bool -  Sha256 :: Expr ByteString -> Expr ByteString-  Sha512 :: Expr ByteString -> Expr ByteString-  Blake2b :: Expr ByteString -> Expr ByteString+  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)   HashKey :: Expr PublicKey -> Expr KeyHash    ChainId :: Expr ChainId@@ -355,6 +369,11 @@     -> Expr ftype     -> ObjectManipulation dt +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@@ -477,3 +496,11 @@   ( exN :~> n   , SizeOpHs n   )++--data Expr2 a where+--  C2 :: (NiceConstant a, HasNoOp (ToT a)) => a -> Expr2 a+--+--instance Buildable (Expr2 a) where+--  build (C2 (x :: a)) = pretty (toVal x)++deriveExprBuildable ''Expr

@@ -28,10 +28,11 @@ import Data.Typeable ((:~:)(..), eqT, typeRep) import Data.Vinyl ((<+>)) import Data.Vinyl.TypeLevel (type (++))+import Fmt (pretty) import Prelude hiding (tail)  import Indigo.Internal.Var-  (HasSideEffects, Ops, RefId, StackVars, StkEl(..), Var(..), operationsVar)+  (HasSideEffects, Ops, RefId, StackVars(..), StackVars', StkEl(..), Var(..), operationsVar) import Indigo.Lorentz import qualified Lorentz.Instr as L import qualified Lorentz.Macro as L@@ -45,13 +46,15 @@ ----------------------------------------------------------------------------  -- | 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 ref stk = case varDepth @a ref stk of+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 ref stk = case varDepth @a ref stk of+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@@ -62,7 +65,8 @@   -> StackVars stk   -> '[b, a] :-> '[a]   -> (b ': stk) :-> stk-varActionUpdate v stk instr = case varDepth @a v stk of+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@@ -87,7 +91,7 @@      , s ~ ((Take m inp) ++ (a ':  a ': Drop ('S m) inp))      , tail ~ (Drop ('S m) inp)      )-  => Sing m -> RefId -> StackVars inp -> inp :-> (a ': inp)+  => Sing m -> RefId -> StackVars' inp -> inp :-> (a ': inp) duupXVar m v stk =   withVarMaybeDict (duupXClassConstraint n stk a s tail) $     L.duupXImpl @('S m) @inp @a @s @tail@@ -105,7 +109,7 @@      , mid ~ (Take n (a ': s) ++ Drop n s)      , tail ~ Drop n s      )-  => Sing n -> RefId -> StackVars (a ': s) -> (a ': s) :-> 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@@ -121,7 +125,7 @@      , tail ~ Drop n s      , mid ~ ((Drop ('S 'Z) (Take n (a ': s))) ++ (a ': Drop n (a ': s)))      )-  => Sing n -> RefId -> StackVars (a ': s)+  => Sing n -> RefId -> StackVars' (a ': s)   -> '[a, b] :-> '[b]   -> (a ': s) :-> s updateNVar n v stk@(a :& s) instr =@@ -154,22 +158,22 @@ varDepth   :: forall a s. KnownValue a   => RefId-  -> StackVars s+  -> StackVars' s   -> VarDepth varDepth refId = \case   RNil -> error $     "You are looking for manually created or leaked variable. " <>-    "Ref #" <> show refId <> " of type " <> show (typeRep (Proxy @a))+    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+  :: 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. Ref #" <> show ref <>+      "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@@ -180,7 +184,7 @@ ----------------------------------------------------------------------------  duupXClassConstraint-  :: Sing n -> StackVars inp -> StkEl a -> StackVars s -> StackVars s'+  :: Sing n -> StackVars' inp -> StkEl a -> StackVars' s -> StackVars' s'   -> Maybe (Dict (L.DuupX n inp a s s')) duupXClassConstraint n inp a s s' = case n of   SZ -> Nothing@@ -199,7 +203,7 @@     return Dict  replaceNClassConstraint-  :: Sing n -> StackVars s -> StkEl a -> StackVars mid -> StackVars tail+  :: 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@@ -213,7 +217,7 @@     return Dict  updateNClassConstraint-  :: Sing n -> StackVars s -> StkEl a -> StkEl b -> StackVars mid -> StackVars tail+  :: 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@@ -239,7 +243,7 @@  duupXLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars inp -> StkEl a -> StackVars s -> StackVars s'+  => Sing n -> StackVars' inp -> StkEl a -> StackVars' s -> StackVars' s'   -> Maybe (Dict (L.ConstraintDuupXLorentz n inp a s s')) duupXLorentzConstraint n s a s1 tail = do   Refl <- testEquality tail (rdrop (SS n) s)@@ -250,7 +254,7 @@  updateNLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars s -> StkEl a -> StkEl b -> StackVars mid -> StackVars tail+  => 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)@@ -261,7 +265,7 @@  replaceNLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars s -> StkEl a -> StackVars mid -> StackVars tail+  => 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)@@ -272,7 +276,7 @@  dugLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars inp -> StackVars out -> StkEl a+  => 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@@ -281,7 +285,7 @@  dipNLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars inp -> StackVars out -> StackVars s -> StackVars s'+  => 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'@@ -290,7 +294,7 @@  digLorentzConstraint   :: (KnownPeano n, SingI n)-  => Sing n -> StackVars inp -> StackVars out -> StkEl a+  => Sing n -> StackVars' inp -> StackVars' out -> StkEl a   -> Maybe (Dict (L.ConstraintDIGLorentz n inp out a)) digLorentzConstraint n inp out a = do   Dict <- digConstraint n inp out a@@ -350,7 +354,7 @@   NoRef -> TVal @(ToT a)   Ref _ -> TVal @(ToT a) -toTVals :: StackVars stk -> TValStack (ToTs stk)+toTVals :: StackVars' stk -> TValStack (ToTs stk) toTVals = \case   RNil          -> RNil   (NoRef :& xs) -> TVal :& toTVals xs

@@ -20,7 +20,7 @@   , castFieldConstructors   ) where -import Data.Vinyl (RMap)+import Data.Vinyl (RMap, RecordToList) import Data.Vinyl.TypeLevel (AllConstrained) import Data.Constraint (Dict(..)) import qualified GHC.Generics as G@@ -140,6 +140,7 @@   ( ToDeconstructC a   , ToConstructC a   , AllConstrained IsObject (FieldTypes a)+  , RecordToList (FieldTypes a) -- for Buildable   )  -- | Type class instantiated for all possible Indigo types

@@ -14,7 +14,6 @@ import Indigo.Prelude  import Indigo.Internal.State-import Indigo.Lorentz  -- | 'GenCode' with hidden output stack data SomeGenCode inp where

@@ -31,7 +31,15 @@   , withStackVars    , DecomposedObjects+  , GenCodeHooks (..)+  , emptyGenCodeHooks   , MetaData (..)+  , stmtHook+  , stmtHookState+  , auxiliaryHook+  , auxiliaryHookState+  , exprHook+  , exprHookState   , replStkMd   , alterStkMd   , pushRefMd@@ -40,16 +48,19 @@    , GenCode (..)   , cleanGenCode++  , (##)   ) where  import qualified Data.Map as M-import Data.Typeable ((:~:)(..), eqT)+import Data.Typeable ((:~:) (..), eqT) +import Indigo.Backend.Prelude import Indigo.Internal.Object import Indigo.Internal.Var-import Indigo.Backend.Prelude import Indigo.Lorentz import qualified Lorentz.Instr as L+import qualified Michelson.Typed as M import Util.Peano  ----------------------------------------------------------------------------@@ -91,7 +102,7 @@ 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 :: KnownValue x => Var x -> IndigoState (x : inp) (x : inp) assignTopVar var = IndigoState $ \md ->   GenCode (assignVarAt var (mdStack md) SZ) L.nop L.nop @@ -129,24 +140,71 @@ 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) f = MetaData (f stk) objs+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 :: 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 :: KnownValue a => MetaData inp -> MetaData (a : inp) pushNoRefMd md = alterStkMd md pushNoRef  -- | 'popNoRef' version for 'MetaData'-popNoRefMd :: MetaData (a & inp) -> MetaData inp+popNoRefMd :: MetaData (a : inp) -> MetaData inp popNoRefMd md = alterStkMd md popNoRef  ----------------------------------------------------------------------------@@ -167,3 +225,23 @@ -- 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

@@ -6,7 +6,8 @@   ( -- * Variables     Var (..)   , RefId-  , StackVars+  , StackVars (..)+  , StackVars'   , StkEl (..)    -- * Stack operations@@ -29,6 +30,7 @@ import Data.Singletons (Sing) import Data.Type.Equality (TestEquality(..)) import Data.Typeable (eqT)+import Fmt (Buildable(..), pretty)  import Indigo.Backend.Prelude import Indigo.Lorentz@@ -43,6 +45,9 @@   deriving stock (Show, Generic)   deriving newtype (Eq, Ord, Real, Num, 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@@ -58,25 +63,34 @@   testEquality (Ref _) NoRef = eqT   testEquality NoRef (Ref _) = eqT +type StackVars' stk = Rec StkEl stk+ -- | Stack of the symbolic interpreter.-type StackVars (stk :: [Kind.Type]) = Rec StkEl stk+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 = RNil+emptyStack = StkElements RNil  instance Default (StackVars '[]) where   def = emptyStack  instance (KnownValue x, Default (StackVars xs)) => Default (StackVars (x ': xs)) where-  def = NoRef :& def+  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'.@@ -88,29 +102,34 @@   -> StackVars inp   -> Sing n   -> StackVars inp-assignVarAt var@(Var varRef) md@(top :& xs) = \case-  SS n -> appendToStack top $ assignVarAt var xs n+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 -> md+    Ref mdRef | mdRef == varRef -> st     Ref _ -> error "Tried to assign a Var to an already referenced value"-    NoRef -> Ref varRef :& xs+    NoRef -> StkElements $ Ref varRef :& xs   where     appendToStack :: StkEl x -> StackVars inp -> StackVars (x ': inp)-    appendToStack v st = v :& st+    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 (Var ref) xs = Ref ref :& xs+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 xs = NoRef :& xs+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 (NoRef :& xs) = xs-popNoRef (Ref refId :& _) =+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 #" <> show refId  ----------------------------------------------------------------------------

@@ -16,6 +16,7 @@ import Lorentz.Annotation as L (HasAnnotation) import Lorentz.Arith as L import Lorentz.Base as L+import Lorentz.Bytes as L import Lorentz.Coercions as L import Lorentz.Common as L import Lorentz.Constraints as L

@@ -30,11 +30,12 @@      , NiceStorage st      )   => Bool -- ^ Force result to be single line+  -> CommentSettings   -> IndigoContract param st   -> LText-printIndigoContract forceSingleLine ctr = printLorentzContract forceSingleLine $+printIndigoContract forceSingleLine sett ctr = printLorentzContract forceSingleLine $   defaultContract $-  compileIndigoContract @param @st ctr+  compileIndigoContractFull @param @st sett ctr  -- | Generate an Indigo contract documentation. renderIndigoDoc@@ -56,9 +57,10 @@      , NiceParameterFull param, NiceStorage st      , MonadIO m      )-  => IndigoContract param st+  => CommentSettings+  -> IndigoContract param st   -> m ()-printAsMichelson cntr = putStrLn (printIndigoContract @param @st False cntr)+printAsMichelson sett cntr = putStrLn (printIndigoContract @param @st False sett cntr)  -- | Saves the pretty-printed Michelson code of an Indigo contract to -- the given file.@@ -69,11 +71,12 @@      , NiceParameterFull param, NiceStorage st      , MonadIO m, MonadMask m      )-  => IndigoContract param st+  => CommentSettings+  -> IndigoContract param st   -> FilePath   -> m ()-saveAsMichelson cntr filePath =-  writeFile filePath (printIndigoContract @param @st False cntr)+saveAsMichelson sett cntr filePath =+  writeFile filePath (printIndigoContract @param @st False sett cntr)  -- | Print the generated documentation to the standard output. printDocumentation

@@ -16,10 +16,11 @@   , contractDocLorentz   , contractOpsLorentz   , contractAssertLorentz-  , contractCommentLorentz+  , contractUserCommentLorentz   , contractIfRightLorentz   , contractIfConsLorentz   , contractWhileLeftLorentz+  , contractWhileLeftIndigo   ) where  import Indigo@@ -67,7 +68,7 @@  contractCaseLorentz :: ContractCode DummyOp Integer contractCaseLorentz = compileIndigoContract $ \param -> scope do-  -- This example demostrates following:+  -- This example demonstrates the following:   -- 1. types of the stack case branched may be diverged,   --    they are automatically moved to the same stack   -- 2. branches can return not exactly the same types@@ -129,8 +130,8 @@   assert negativeResM (s > z)   storageVar =: s -contractCommentLorentz :: ContractCode Integer Integer-contractCommentLorentz = compileIndigoContract $ \param -> do+contractUserCommentLorentz :: ContractCode Integer Integer+contractUserCommentLorentz = compileIndigoContract $ \param -> do   s <- commentAroundStmt "param plus storage" $ new$ param + storageVar @Integer   _z <- new$ 0 int   justComment "just comment"@@ -165,14 +166,21 @@     (storageVar =: 0 int)  contractWhileLeftLorentz :: ContractCode Integer Integer-contractWhileLeftLorentz = compileIndigoContract $ \param -> do+contractWhileLeftLorentz = compileIndigoContract contractWhileLeftIndigo++-- This contract is used for a demonstration of automatic commenting capabilities+contractWhileLeftIndigo :: HasStorage Integer => Var Integer -> IndigoM ()+contractWhileLeftIndigo param = do   iL <- new$ left $ param-  s <- whileLeft (iL) \i -> do-    if_ (i >= 10 int)-      (iL =: right i)-      (do-        if_ (i % 2 int == 0 nat)-          (iL =: left $ i + 2 int)-          (iL =: right i)-      )+  s <- whileLeft iL $ whileBody iL   storageVar =: s+  where+    whileBody :: HasCallStack => Var (Either Integer Integer) -> Var Integer -> IndigoM ()+    whileBody iL i =+      if_ (i >= 10 int)+        (iL =: right i)+        (do+          if_ (i % 2 int == 0 nat)+            (iL =: left $ i + 2 int)+            (iL =: right i)+        )

@@ -155,10 +155,10 @@ exprSnd = compileIndigo @2 $ \st param -> st =: snd param  exprPack :: '[Signature, ByteString] :-> '[Signature, ByteString]-exprPack = compileIndigo @2 $ \st param -> st =: pack param+exprPack = compileIndigo @2 $ \st param -> st =: packRaw param  exprUnpack :: '[ByteString, Maybe Signature] :-> '[ByteString, Maybe Signature]-exprUnpack= compileIndigo @2 $ \st param -> st =: unpack param+exprUnpack = compileIndigo @2 $ \st param -> st =: unpackRaw param  exprSet :: '[(Set Integer), Integer] :-> '[(Set Integer), Integer] exprSet = compileIndigo @2 $ \st param -> do@@ -225,7 +225,7 @@     phi SignatureData{..} st _param = do       st =: checkSignature         (constExpr $ partialParse C.parsePublicKey sdPublicKey)-        (constExpr $ partialParse C.parseSignature sdSignature)+        (constExpr $ TSignature $ partialParse C.parseSignature sdSignature)         (constExpr sdBytes)  exprCrypto@@ -233,8 +233,8 @@   :-> '[ByteString, ByteString] exprCrypto = compileIndigo @2 $ \st param -> do   _sha256var <- new$ sha256 param-  st =: blake2b param-  param =: sha512 param+  st =: coerce (blake2b param)+  param =: coerce (sha512 param)  exprHashKey :: '[PublicKey, KeyHash] :-> '[PublicKey, KeyHash] exprHashKey = compileIndigo @2 $ \st param -> do

@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.DebugComments+       ( whileLeftComments+       , pathFrontendComments+       , pathBackendComments+       , pathAuxComments+       , pathExprComments+       , pathDebugCommentsFullStack+       , whileLeftCommentsFullStack+       , test_Comments+       ) where++import Prelude hiding (drop, swap)++import Hedgehog (Gen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree)++import Indigo.Compilation+import Lorentz+import Test.Code.Examples (contractWhileLeftIndigo)+import Test.Util++--------------------------------------------------------------------------------+-- Tests+--------------------------------------------------------------------------------++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++test_Comments :: [TestTree]+test_Comments =+  [ testIndigoContract "Frontend comments"+      genInteger+      genInteger+      (\_ _ _ -> pure ())+      (whileLeftComments LogTopLevelFrontendStatements)+      pathFrontendComments++  , testIndigoContract "Backend comments"+      genInteger+      genInteger+      (\_ _ _ -> pure ())+      (whileLeftComments LogBackendStatements)+      pathBackendComments++  , testIndigoContract "Aux comments"+      genInteger+      genInteger+      (\_ _ _ -> pure ())+      (whileLeftComments LogAuxCode)+      pathAuxComments++  , testIndigoContract "Expression comments"+      genInteger+      genInteger+      (\_ _ _ -> pure ())+      (whileLeftComments LogExpressionsComputations)+      pathExprComments+  ]+  where+    genInteger :: Gen Integer+    genInteger = Gen.integral (Range.linearFrom 0 -1000 1000)++whileLeftComments :: CommentsVerbosity -> ContractCode Integer Integer+whileLeftComments level =+  compileIndigoContractFull+    (defaultCommentSettings level)+    contractWhileLeftIndigo++whileLeftCommentsFullStack :: ContractCode Integer Integer+whileLeftCommentsFullStack =+  compileIndigoContractFull+    (defaultCommentSettings LogTopLevelFrontendStatements) { csPrintFullStackTrace = True }+    contractWhileLeftIndigo++pathFrontendComments :: FilePath+pathFrontendComments = "test/contracts/golden/debug/frontend_comments.tz"++pathBackendComments :: FilePath+pathBackendComments = "test/contracts/golden/debug/backend_comments.tz"++pathAuxComments :: FilePath+pathAuxComments = "test/contracts/golden/debug/aux_comments.tz"++pathExprComments :: FilePath+pathExprComments = "test/contracts/golden/debug/expr_comments.tz"++pathDebugCommentsFullStack :: FilePath+pathDebugCommentsFullStack = "test/contracts/golden/debug/fullstack_comments.tz"

@@ -19,7 +19,7 @@   , contractCaseLorentz   , contractOpsLorentz   , contractAssertLorentz-  , contractCommentLorentz+  , contractUserCommentLorentz   , pathWhile   , pathWhileLeft   , pathForEach@@ -136,7 +136,7 @@       genInteger       genInteger       (\_ _ _ -> pure ())-      contractCommentLorentz+      contractUserCommentLorentz       pathComment   ]   where

@@ -58,7 +58,7 @@   , testCase "Outer scope error" $       (pure $! lambdaOuterVarClosure)       `shouldThrow`-      (errorCall "You are looking for manually created or leaked variable. Ref #RefId 3 of type Integer")+      (errorCall "You are looking for manually created or leaked variable. #ref3 of type Integer")   ]   where     genInteger = Gen.integral (Range.linearFrom 0 -1000 1000)

@@ -26,11 +26,11 @@  type FourInts = '[Integer, Integer, Integer, Integer] -fullMd :: StackVars FourInts-fullMd = Ref 3 :& Ref 2 :& Ref 1 :& Ref 0 :& RNil+fullStk :: StackVars' FourInts+fullStk = Ref 3 :& Ref 2 :& Ref 1 :& Ref 0 :& RNil  nthVar :: Sing (n :: Peano) -> RefId-nthVar n = case rdrop n fullMd of+nthVar n = case rdrop n fullStk of   (Ref refId :: StkEl a) :& _ -> case eqT @a @Integer of     Just Refl -> refId     Nothing -> error "impossible: all Vars are for Integers"@@ -91,7 +91,7 @@      , L.DuupX ('S n) FourInts Integer s1 tail      )   => Sing ('S n) -> Assertion-testVarActionGet (SS n) = duupXInstr @?= varActionGet (nthVar n) fullMd+testVarActionGet (SS n) = duupXInstr @?= varActionGet (nthVar n) (StkElements fullStk)   where     duupXInstr :: FourInts :-> (Integer ': FourInts)     duupXInstr = L.duupXImpl @('S n) @FourInts @Integer @s1 @tail@@ -102,7 +102,7 @@      , L.ReplaceN ('S n) FourInts Integer mid tail      )   => Sing ('S n) -> Assertion-testVarActionSet (SS n) = replaceNInstr @?= varActionSet (nthVar n) fullMd+testVarActionSet (SS n) = replaceNInstr @?= varActionSet (nthVar n) (StkElements fullStk)   where     replaceNInstr :: (Integer ': FourInts) :-> FourInts     replaceNInstr = L.replaceNImpl @('S n) @FourInts @Integer @mid @tail@@ -113,7 +113,7 @@      , L.UpdateN ('S n) FourInts Integer Integer mid tail      )   => Sing ('S n) -> Assertion-testVarActionUpdate (SS n) = updateNInstr @?= varActionUpdate @Integer (nthVar n) fullMd L.add+testVarActionUpdate (SS n) = updateNInstr @?= varActionUpdate @Integer (nthVar n) (StkElements fullStk) L.add   where     updateNInstr :: (Integer ': FourInts) :-> FourInts     updateNInstr = L.updateNImpl @('S n) @FourInts @Integer @Integer @mid @tail L.add

@@ -20,6 +20,7 @@ import Test.Examples import Test.Lambda import Test.Util+import Test.DebugComments  newtype RegenGoldenTests = RegenGoldenTests Bool   deriving newtype (Eq, Ord)@@ -61,7 +62,7 @@   saveToFile contractCaseLorentz pathCase   saveToFile contractOpsLorentz pathOps   saveToFile contractAssertLorentz pathAssert-  saveToFile contractCommentLorentz pathComment+  saveToFile contractUserCommentLorentz pathComment    -- Lambda   saveToFile sumLambdaCalledOnce pathSumLambdaCalledOnce@@ -69,6 +70,13 @@   saveToFile lambdasSideEffects pathLambdasSideEffects   saveToFile lambdaInLambda1 pathLambdaInLambda1   saveToFile lambdaInLambda2 pathLambdaInLambda2++  -- Debug Comments+  saveToFile (whileLeftComments LogTopLevelFrontendStatements) pathFrontendComments+  saveToFile (whileLeftComments LogBackendStatements) pathBackendComments+  saveToFile (whileLeftComments LogAuxCode) pathAuxComments+  saveToFile (whileLeftComments LogExpressionsComputations) pathExprComments+  saveToFile whileLeftCommentsFullStack pathDebugCommentsFullStack    putTextLn "Regenerate completed."   return True