Types.hs

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

-- | 'Instruction' datatype.
module Indigo.Compilation.Sequential.Types
  ( Block
  , Instruction (..)

  , IndigoSeqCaseClause (..)
  , CaseBranch (..)

  -- * Translations
  , SequentialHooks (..)
  , InstrCollector (..)
  , stmtHookL
  ) where

import Prelude

import Lens.Micro.TH (makeLensesFor)
import Lorentz.Entrypoints.Helpers (RequireSumType)
import Lorentz.Run qualified as L (Contract)
import Morley.Michelson.Typed.Haskell.Instr.Sum (CaseClauseParam(..), CtorField(..))
import Morley.Michelson.Untyped.Annotation (FieldAnn)
import Morley.Util.TypeLits (AppendSymbol)

import Indigo.Backend
import Indigo.Common.Expr (Expr)
import Indigo.Common.Field (HasField)
import Indigo.Common.SIS
import Indigo.Common.Var
import Indigo.Lorentz hiding (comment)

-- | Simple synonym for a list of 'Instruction'
type Block = [Instruction]

-- | Data type representing an instruction.
--
-- Differently from the frontend this is not used to build a Monad of some kind,
-- it is instead based on having as argument the variable to associate with the
-- resulting value (if any).
--
-- This is combined in simple lists, named 'Block', and it is intended to be
-- easily altered, this is because these are used as the intermediate representation
-- between the frontend and the backend, where optimizations can occur.
data Instruction where
  LiftIndigoState :: (forall inp. SomeIndigoState inp) -> Instruction
  Comment :: Text -> Instruction

  AssignVar :: KnownValue x => Var x -> Expr x -> Instruction
  SetVar :: KnownValue x => Var x -> Expr x -> Instruction
  VarModification
    :: (IsObject x, KnownValue y)
    => [y, x] :-> '[x]
    -> Var x
    -> Expr y
    -> Instruction
  SetField
    :: ( HasField store fname ftype
       , IsObject store
       , IsObject ftype
       )
    => Var store -> Label fname -> Expr ftype -> Instruction

  LambdaCall1
    :: LambdaKind st arg ret extra
    -- ^ Kind of lambda (pure, storage modification, fully functional lambda with effects)
    -> String
    -- ^ Name of the lambda
    -> Expr arg
    -- ^ Expression for the lambda argument
    -> Var arg
    -- ^ Variable for the argument value (available to the lambda code block)
    -> Block
    -- ^ Code block for the lambda
    -> ret
    -- ^ Return value(s) of the lambda
    -> RetVars ret
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction

  CreateLambda1
    :: CreateLambda1CGeneric extra arg ret
    => StackVars (arg : extra)
    -- ^ Initial 'StackVars' to be used in the lambda code
    -> Var arg
    -- ^ Variable for the argument value (available to the lambda code block)
    -> Block
    -- ^ Code block for the lambda
    -> ret
    -- ^ Return value(s) of the lambda
    -> Var (Lambda1Generic extra arg ret)
    -- ^ Variable that will be assigned to the resulting lambda
    -> Instruction

  ExecLambda1
    :: LambdaKind st arg ret extra
    -> Proxy ret
    -> Expr arg
    -- ^ Expression for the lambda argument
    -> Var (Lambda1Generic extra arg ret)
    -- ^ Variable of the lambda to be executed
    -> RetVars ret
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction

  Scope
    :: ScopeCodeGen ret
    => Block
    -- ^ Code block to execute inside the scope
    -> ret
    -- ^ Return value(s) of the scoped code block
    -> RetVars ret
    -- ^ Variable that will be assigned to the resulting value(s)
    -> Instruction
  If
    :: IfConstraint a b
    => Expr Bool
    -- ^ Expression for the control flow
    -> Block
    -- ^ Code block for the positive branch
    -> a
    -- ^ Return value(s) of the positive branch
    -> Block
    -- ^ Code block for the negative branch
    -> b
    -- ^ Return value(s) of the negative branch
    -> RetVars a
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction
  IfSome
    :: (IfConstraint a b, KnownValue x)
    => Expr (Maybe x)
    -- ^ Expression for the control flow
    -> Var x
    -- ^ Variable for the 'Just' value (available to the next code block)
    -> Block
    -- ^ Code block for the 'Just' branch
    -> a
    -- ^ Return value(s) of the 'Just' branch
    -> Block
    -- ^ Code block for the 'Nothing' branch
    -> b
    -- ^ Return value(s) of the 'Nothing' branch
    -> RetVars a
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction
  IfRight
    :: (IfConstraint a b, KnownValue r, KnownValue l)
    => Expr (Either l r)
    -- ^ Expression for the control flow
    -> Var r
    -- ^ Variable for the 'Right' value (available to the next code block)
    -> Block
    -- ^ Code block for the 'Right' branch
    -> a
    -- ^ Return value(s) of the 'Right' branch
    -> Var l
    -- ^ Variable for the 'Left' value (available to the next code block)
    -> Block
    -- ^ Code block for the 'Left' branch
    -> b
    -- ^ Return value(s) of the 'Left' branch
    -> RetVars a
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction
  IfCons
    :: (IfConstraint a b, KnownValue x)
    => Expr (List x)
    -- ^ Expression for the control flow
    -> Var x
    -- ^ Variable for the "head" value (available to the next code block)
    -> Var (List x)
    -- ^ Variable for the "tail" value (available to the next code block)
    -> Block
    -- ^ Code block for the non-empty list branch
    -> a
    -- ^ Return value(s) of the non-empty list branch
    -> Block
    -- ^ Code block for the empty list branch
    -> b
    -- ^ Return value(s) of the empty list branch
    -> RetVars a
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction

  Case
    :: CaseCommon dt ret clauses
    => Expr dt
    -> clauses
    -> RetVars ret
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction
  EntryCase
    :: ( CaseCommon dt ret clauses
       , DocumentEntrypoints entryPointKind dt
       )
    => Proxy entryPointKind
    -> Expr dt
    -> clauses
    -> RetVars ret
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction
  EntryCaseSimple
    :: ( CaseCommon dt ret clauses
       , DocumentEntrypoints PlainEntrypointsKind dt
       , NiceParameterFull dt
       , RequireFlatParamEps dt
       )
    => Expr dt
    -> clauses
    -> RetVars ret
    -- ^ Variable(s) that will be assigned to the resulting value(s)
    -> Instruction

  While
    :: Expr Bool
    -- ^ Expression for the control flow
    -> Block
    -- ^ Block of code to execute, as long as the expression holds 'True'
    -> Instruction
  WhileLeft
    :: (KnownValue l, KnownValue r)
    => Expr (Either l r)
    -- ^ Expression for the control flow value
    -> Var l
    -- ^ Variable for the 'Left' value (available to the code block)
    -> Block
    -- ^ Code block to execute while the value is 'Left'
    -> Var r
    -- ^ Variable that will be assigned to the resulting value
    -> Instruction
  ForEach
    :: (IterOpHs a, KnownValue (IterOpElHs a))
    => Expr a
    -- ^ Expression for the container to traverse
    -> Var (IterOpElHs a)
    -- ^ Variable for the current item (available to the code block)
    -> Block
    -- ^ Code block to execute over each element of the container
    -> Instruction

  ContractName
    :: Text
    -> Block
    -> Instruction
  DocGroup
    :: forall di. DocItem di
    => (SubDoc -> di)
    -> Block
    -> Instruction
  ContractGeneral
    :: Block
    -> Instruction
  FinalizeParamCallingDoc
    :: (NiceParameterFull cp, RequireSumType cp)
    => Var cp
    -> Block
    -> Expr cp
    -> Instruction

  TransferTokens
    :: (NiceParameter p, HasSideEffects, IsNotInView)
    => Expr p
    -> Expr Mutez
    -> Expr (ContractRef p)
    -> Instruction
  SetDelegate
    :: (HasSideEffects, IsNotInView)
    => Expr (Maybe KeyHash)
    -> Instruction

  CreateContract
    :: ( HasSideEffects, NiceStorage s, NiceParameterFull p
       , NiceViewsDescriptor vd, Typeable vd, IsNotInView
       )
    => L.Contract p s vd
    -> Expr (Maybe KeyHash)
    -> Expr Mutez
    -> Expr s
    -> Var Address
    -- ^ Variable that will be assigned to the resulting 'Address'
    -> Instruction
  SelfCalling
    :: ( NiceParameterFull p
       , KnownValue (GetEntrypointArgCustom p mname)
       , IsoValue (ContractRef (GetEntrypointArgCustom p mname))
       , IsNotInView
       )
    => Proxy p
    -> EntrypointRef mname
    -> Var (ContractRef (GetEntrypointArgCustom p mname))
    -- ^ Variable that will be assigned to the resulting 'ContractRef'
    -> Instruction
  ContractCalling
    :: ( HasEntrypointArg cp epRef epArg
       , ToTAddress cp vd addr
       , ToT addr ~ ToT Address
       , KnownValue epArg
       , IsoValue (ContractRef epArg)
       )
    => Proxy (cp, vd)
    -> epRef
    -> Expr addr
    -> Var (Maybe (ContractRef epArg))
    -- ^ Variable that will be assigned to the resulting 'ContractRef'
    -> Instruction
  Emit :: (HasSideEffects, NicePackedValue a, HasAnnotation a) => FieldAnn -> Expr a -> Instruction

  Fail
    :: (forall inp. SomeIndigoState inp)
    -> Instruction
  FailOver
    :: (forall inp. Expr a -> SomeIndigoState inp)
    -> Expr a
    -> Instruction

----------------------------------------------------------------------------
-- Translations
----------------------------------------------------------------------------

-- | Data type internally used to collect 'Instruction's from 'IndigoM'
data InstrCollector = InstrCollector
  { nextRef   :: RefId
  , instrList :: Block
  , seqHooks  :: SequentialHooks
  }

newtype SequentialHooks = SequentialHooks {
    shStmtHook    :: CallStack -> Block -> State InstrCollector ()
  }

instance Semigroup SequentialHooks where
  SequentialHooks s <> SequentialHooks s1 = SequentialHooks (\t -> s t >> s1 t)

instance Monoid SequentialHooks where
  mempty = SequentialHooks (const $ appendNewInstrs . reverse)

appendNewInstrs :: Block -> State InstrCollector ()
appendNewInstrs blk = modify $ \iColl -> iColl {instrList = blk ++ instrList iColl}

----------------------------------------------------------------------------
-- Case machinery
----------------------------------------------------------------------------

-- | Common constraint for case-like 'Instruction's.
type CaseCommon dt ret clauses = CaseCommonF IndigoSeqCaseClause dt ret clauses

-- | Analogous datatype as 'IndigoCaseClauseL' and 'IndigoMCaseClauseL'.
data IndigoSeqCaseClause ret (param :: CaseClauseParam) where
  OneFieldIndigoSeqCaseClause
    :: (AppendSymbol "c" ctor ~ name)
    => Label name
    -> CaseBranch x ret
    -> IndigoSeqCaseClause ret ('CaseClauseParam ctor ('OneField x))

-- | Representation of a branch of a generic case-like 'Instruction'.
data CaseBranch x ret where
  CaseBranch
    :: ( KnownValue x
       , ScopeCodeGen retBr
       , ret ~ RetExprs retBr
       , RetOutStack ret ~ RetOutStack retBr
       )
    => Var x
    -- ^ Input variable (accessible to the branch's code block)
    -> Block
    -- ^ Code block for this branch
    -> retBr
    -- ^ Return value of this branch
    -> CaseBranch x ret

makeLensesFor [ ("shStmtHook", "stmtHookL")] ''SequentialHooks