Backend.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

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

-- | Indigo compiler back-end helpers.
--
-- For reference, "back-end" refers to the part of the compiler pipeline
-- that comes after the intermediate representation. In our case, intermediate
-- representation is defined in "Indigo.Frontend.Internal.Statement".
--
-- Essentially these definitions simplify target code generation.
-- This is not intended to be exported from "Indigo".
module Indigo.Backend
  ( module ReExports

  -- * Loop
  , forEach
  , while
  , whileLeft

  -- * Contract call
  , selfCalling
  , contractCalling

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

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

  -- * 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.Expr.Compilation as ReExports
import Indigo.Backend.Expr.Decompose as ReExports
import Indigo.Backend.Lambda as ReExports
import Indigo.Backend.Lookup as ReExports
import Indigo.Backend.Scope as ReExports
import Indigo.Backend.Var as ReExports

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

import Indigo.Backend.Prelude
import Indigo.Common.Expr (Expr)
import Indigo.Common.SIS
  (SomeGenCode(SomeGenCode), SomeIndigoState(SomeIndigoState), overSIS, runSIS)
import Indigo.Common.State
import Indigo.Common.Var (HasSideEffects, Var, pushNoRef, pushRef)
import Indigo.Lorentz hiding (comment)
import Lorentz.Doc qualified as L
import Lorentz.Entrypoints.Doc qualified as L (finalizeParamCallingDoc)
import Lorentz.Entrypoints.Helpers (RequireSumType)
import Lorentz.Ext qualified as L
import Lorentz.Instr qualified as L
import Lorentz.Run qualified as L
import Morley.Michelson.Typed qualified as MT
import Morley.Michelson.Untyped.Annotation (FieldAnn)
import Morley.Util.Type (type (++))

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

-- | 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)
     , IsoValue (ContractRef (GetEntrypointArgCustom p mname))
     , IsNotInView
     )
  => 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 vd inp epRef epArg addr.
     ( HasEntrypointArg cp epRef epArg
     , ToTAddress cp vd addr
     , ToT addr ~ ToT Address
     , MT.HasNoOp (ToT epArg)
     , MT.HasNoNestedBigMaps (ToT epArg)
     , 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 @_ @_ @_ @vd epRef)
  assignTopVar var

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

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

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

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

emit
  :: (HasSideEffects, NicePackedValue a, HasAnnotation a)
  => FieldAnn -> Expr a -> IndigoState inp inp
emit tag ex = withStackVars $ \s ->
  unaryOpFlat ex $ L.emit tag # varActionOperation s

----------------------------------------------------------------------------
-- Functions, Procedures and Scopes
----------------------------------------------------------------------------

-- | 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