Backend.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Strictly typed statements of Indigo language.

module Indigo.Backend
  ( module ReExports

  -- * Loop
  , forEach
  , while
  , whileLeft

  -- * Contract call
  , selfCalling
  , contractCalling

  -- * Documentation
  , doc
  , docGroup
  , docStorage
  , contractName
  , finalizeParamCallingDoc
  , contractGeneral
  , contractGeneralDefault

  -- * Side-effects
  , transferTokens
  , setDelegate
  , createContract

  -- * Functions, Procedures and Scopes
  , scope

  -- * Comments
  , comment
  ) where

import Indigo.Backend.Case as ReExports
import Indigo.Backend.Conditional as ReExports
import Indigo.Backend.Error as ReExports
import Indigo.Backend.Lambda as ReExports
import Indigo.Backend.Scope as ReExports
import Indigo.Backend.Var as ReExports

import Fmt (build, fmt, pretty, (+|), (|+))

import Indigo.Backend.Prelude
import Indigo.Internal hiding ((<>))
import Indigo.Lorentz
import qualified Lorentz.Doc as L
import qualified Lorentz.Entrypoints.Doc as L (finalizeParamCallingDoc)
import Lorentz.Entrypoints.Helpers (RequireSumType)
import qualified Lorentz.Instr as L
import qualified Lorentz.Run as L
import qualified Michelson.Typed as MT
import Util.Type (type (++))

----------------------------------------------------------------------------
-- Loop
----------------------------------------------------------------------------

-- | While statement.
while
  :: Expr Bool
  -- ^ Expression for the control flow
  -> SomeIndigoState inp
  -- ^ Block of code to execute, as long as the expression holds 'True'
  -> IndigoState inp inp
while e body = IndigoState $ \md ->
  let expCd = exprHook md (pretty e) $ gcCode $ usingIndigoState md (compileExpr e)
      bodyIndigoState = runSIS body md cleanGenCode
  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
  :: 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)
  -- ^ Code block to execute while the value is 'Left'
  -> Var r
  -- ^ Variable that will be assigned to the resulting value
  -> IndigoState inp (r : inp)
whileLeft e varL body varR = IndigoState $ \md ->
  let
    cde = exprHook md (pretty e) $ gcCode $ usingIndigoState md (compileExpr e)
    newMd = pushRefMd varL md
    bodyCd = runSIS body newMd cleanGenCode
    resSt = pushRef varR $ mdStack md
  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
  :: (IterOpHs a, KnownValue (IterOpElHs a))
  => Expr a
  -- ^ Expression for the container to traverse
  -> Var (IterOpElHs a)
  -- ^ Variable for the current item (available to the code block)
  -> 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 flip (GenCode (mdStack md)) L.nop $ stmtHook md (fmt $ "foreach (" +| var |+ " in " +| container |+ ")") $
        exprHook md (pretty container) cde #
        L.iter (bodyIndigoState # L.drop)

----------------------------------------------------------------------------
-- Documentation
----------------------------------------------------------------------------

-- | Put a document item.
doc :: DocItem di => di -> IndigoState s s
doc di = IndigoState \md -> GenCode (mdStack md) (L.doc di) L.nop

-- | Group documentation built in the given piece of code
-- into a block dedicated to one thing, e.g. to one entrypoint.
docGroup :: DocItem di => (SubDoc -> di) -> SomeIndigoState i -> SomeIndigoState i
docGroup gr = overSIS $ \(GenCode md cd clr) -> SomeGenCode $
  GenCode md (L.docGroup gr cd) clr

-- | Insert documentation of the contract storage type. The type
-- should be passed using type applications.
{-# DEPRECATED docStorage "Use `doc (dStorage @storage)` instead." #-}
docStorage :: forall storage s. TypeHasDoc storage => IndigoState s s
docStorage = doc (dStorage @storage)

-- | Give a name to the given contract. Apply it to the whole contract code.
{-# DEPRECATED contractName "Use `docGroup name` instead." #-}
contractName :: Text -> SomeIndigoState i -> SomeIndigoState i
contractName cName = docGroup (DName cName)

-- | Attach general info to the given contract.
{-# DEPRECATED contractGeneral "Use `docGroup DGeneralInfoSection` instead." #-}
contractGeneral :: SomeIndigoState i -> SomeIndigoState i
contractGeneral = docGroup DGeneralInfoSection

-- | Attach default general info to the contract documentation.
contractGeneralDefault :: IndigoState s s
contractGeneralDefault = IndigoState \md -> GenCode (mdStack md) L.contractGeneralDefault L.nop

-- | Indigo version for the function of the same name from Lorentz.
finalizeParamCallingDoc
  :: (NiceParameterFull cp, RequireSumType cp, HasCallStack)
  => Var cp
  -> 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 $ flip (GenCode st1) (clr # L.drop) $
    stmtHook md ("finalizeParamCallingDoc (" <> pretty param <> ")") $
      exprHook md (pretty param) cde #
      L.finalizeParamCallingDoc cd

----------------------------------------------------------------------------
-- Contract call
----------------------------------------------------------------------------

selfCalling
  :: forall p inp mname.
     ( NiceParameterFull p
     , KnownValue (GetEntrypointArgCustom p mname)
     )
  => 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 = stmtHookState (pretty var <> " := selfCalling " <> pretty (eprName epRef)) $ do
  nullaryOp (L.selfCalling @p epRef)
  assignTopVar var

contractCalling
  :: forall cp inp epRef epArg addr.
     ( HasEntrypointArg cp epRef epArg
     , ToTAddress cp addr
     , ToT addr ~ ToT Address
     , KnownValue epArg
     )
  => epRef
  -> 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 = stmtHookState (pretty var <> " := contractCalling " <> pretty addr) $ do
  unaryOp addr (L.contractCalling @cp epRef)
  assignTopVar var

----------------------------------------------------------------------------
-- Side-effects
----------------------------------------------------------------------------

transferTokens
  :: (NiceParameter p, HasSideEffects)
  => Expr p -> Expr Mutez -> Expr (ContractRef p)
  -> IndigoState inp inp
transferTokens ep em ec = withStackVars $ \s ->
  ternaryOpFlat ep em ec (L.transferTokens # varActionOperation s)

setDelegate :: HasSideEffects => Expr (Maybe KeyHash) -> IndigoState inp inp
setDelegate e = withStackVars $ \s ->
  unaryOpFlat e (L.setDelegate # varActionOperation s)

createContract
  :: (HasSideEffects, NiceStorage s, NiceParameterFull p)
  => L.Contract p s
  -> Expr (Maybe KeyHash)
  -> Expr Mutez
  -> Expr s
  -> Var Address
  -- ^ Variable that will be assigned to the resulting 'Address'
  -> 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
----------------------------------------------------------------------------

-- | Takes an arbitrary 'IndigoM' and wraps it into an 'IndigoFunction'
-- producing a local scope for its execution. Once it executed, all
-- non-returned variables are cleaned up so that the stack has only
-- returned variables at the top. This also can be interpreted as
-- @if True then f else nop@.
--
-- Note, that by default we do not define scope inside indigo functions,
-- meaning that once we want to create a new variable or return it from
-- a function we need to do it inside @scope $ instr@ construction, for
-- example:
--
-- @
-- f :: IndigoFunction s Natural
-- f = scope $ do
--   *[s]*
--   res <- newVar (0 :: Natural)
--   *[Natural, s]*
--   scope $ do
--     _n <- newVar (1 :: Integer)
--     *[Integer, Natural, s]
--     res += 4
--   *[Natural, s]*
--   return res
--   *[s]*
-- @
scope
  :: forall ret inp . ScopeCodeGen ret
  => SomeIndigoState inp
  -- ^ Code block to execute inside the scope
  -> ret
  -- ^ Return value(s) of the scoped code block
  -> RetVars ret
  -- ^ 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 $ stmtHook md (prettyAssign @ret retVars "scope") $
      compileScope @ret (replStkMd md) fs ret

-- | Add a comment
comment :: MT.CommentType -> IndigoState i i
comment t = IndigoState $ \md -> GenCode (mdStack md) (L.comment t) L.nop