indigo-0.4: src/Indigo/Compilation/Sequential.hs

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

-- | 'Instruction' datatype and its compilations.
--
-- The idea behind this module is to provide an intermediate representation that
-- can:
--
-- - be generated from the frontend freer monad
-- - be compiled to the backend 'IndigoState'
-- - be easy to analyze, manipulate and modify
--
-- This is meant to be the common ground for modular optimizations on the code
-- before this is handed off to the backend and eventually translated to
-- Michelson.

module Indigo.Compilation.Sequential
  ( Block
  , Instruction (..)

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

  -- * Translations
  , SequentialHooks (..)
  , stmtHookL
  , InstrCollector (..)
  , indigoMtoSequential
  , sequentialToLorentz

  -- * Case machinery
  , updateClauses
  , mapMClauses
  ) where

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 Indigo.Backend
import Indigo.Frontend.Program
import qualified Indigo.Frontend.Statement as S
import Indigo.Internal (Expr, HasField)
import Indigo.Internal.Object (IsObject)
import Indigo.Internal.SIS
import Indigo.Internal.State hiding ((>>))
import qualified Indigo.Internal.State as St
import Indigo.Internal.Var
import Indigo.Lorentz
import qualified Michelson.Typed as MT

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

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

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

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

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

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

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

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

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

  ContractName
    :: Text
    -> Block
    -> Instruction
  DocGroup
    :: DocGrouping
    -> Block
    -> Instruction
  ContractGeneral
    :: Block
    -> Instruction
  FinalizeParamCallingDoc
    :: (NiceParameterFull cp, RequireSumType cp)
    => Var cp
    -> Block
    -> Expr cp
    -> Instruction

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

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

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

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

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

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

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

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

-- | Transformation from 'IndigoM' to a 'Block' of 'Instruction's.
--
-- Requires the first non-used 'RefId' and returns the next one.
indigoMtoSequential
  :: RefId
  -> SequentialHooks
  -> IndigoM a
  -> (Block, RefId)
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 -> 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
    return var
  S.SetVar vx ex -> appendNewInstr $ SetVar vx ex
  S.VarModification upd vx ey -> appendNewInstr $ VarModification upd vx ey
  S.SetField vStore fname exF -> appendNewInstr $ SetField vStore fname exF

  S.LambdaCall1 lKind lName vIm ex -> withLambdaKind lKind $ do
    (var, block, ret, retVars) <- collectInLambda vIm
    appendNewInstr $ LambdaCall1 lKind lName ex var block ret retVars
    return retVars

  S.Scope (iM :: IndigoM ret) -> do
    retVars <- allocateVars @ret mkNextVar
    (ret, block) <- collectInner iM
    appendNewInstr $ Scope block ret retVars
    return retVars
  S.If ex (iMa :: IndigoM ret) iMb -> do
    retVars <- allocateVars @ret mkNextVar
    (retA, blockA) <- collectInner iMa
    (retB, blockB) <- collectInner iMb
    appendNewInstr $ If ex blockA retA blockB retB retVars
    return retVars
  S.IfSome ex (vIMa :: Var x -> IndigoM ret) iMb -> do
    retVars <- allocateVars @ret mkNextVar
    varX <- mkNextVar
    (retA, blockA) <- collectInner $ vIMa varX
    (retB, blockB) <- collectInner iMb
    appendNewInstr $ IfSome ex varX blockA retA blockB retB retVars
    return retVars
  S.IfRight ex (vIMa :: Var x -> IndigoM ret) vIMb -> do
    retVars <- allocateVars @ret mkNextVar
    varR <- mkNextVar
    (retA, blockA) <- collectInner $ vIMa varR
    varL <- mkNextVar
    (retB, blockB) <- collectInner $ vIMb varL
    appendNewInstr $ IfRight ex varR blockA retA varL blockB retB retVars
    return retVars
  S.IfCons ex (vvIMa :: Var x -> Var (List x) -> IndigoM ret) iMb -> do
    retVars <- allocateVars @ret mkNextVar
    varX <- mkNextVar
    varLX <- mkNextVar
    (retA, blockA) <- collectInner $ vvIMa varX varLX
    (retB, blockB) <- collectInner iMb
    appendNewInstr $ IfCons ex varX varLX blockA retA blockB retB retVars
    return retVars

  S.Case grd clauses -> do
    retVars <- allocateClausesVars clauses
    blockClauses <- collectClauses clauses
    appendNewInstr $ Case grd blockClauses retVars
    return retVars
  S.EntryCase proxy grd clauses -> do
    retVars <- allocateClausesVars clauses
    blockClauses <- collectClauses clauses
    appendNewInstr $ EntryCase proxy grd blockClauses retVars
    return retVars
  S.EntryCaseSimple grd clauses -> do
    retVars <- allocateClausesVars clauses
    blockClauses <- collectClauses clauses
    appendNewInstr $ EntryCaseSimple grd blockClauses retVars
    return retVars

  S.While ex iM -> do
    ((), block) <- collectInner iM
    appendNewInstr $ While ex block
  S.WhileLeft ex vIm -> do
    varL <- mkNextVar
    varR <- mkNextVar
    ((), block) <- collectInner $ vIm varL
    appendNewInstr $ WhileLeft ex varL block varR
    return varR
  S.ForEach ex vIm -> do
    varIop <- mkNextVar
    ((), block) <- collectInner $ vIm varIop
    appendNewInstr $ ForEach ex varIop block

  S.ContractName tx iM -> do
    ((), block) <- collectInner iM
    appendNewInstr $ ContractName tx block
  S.DocGroup dg iM -> do
    ((), block) <- collectInner iM
    appendNewInstr $ DocGroup dg block
  S.ContractGeneral iM -> do
    ((), block) <- collectInner iM
    appendNewInstr $ ContractGeneral block
  S.FinalizeParamCallingDoc vIm param -> do
    varCp <- mkNextVar
    ((), block) <- collectInner $ vIm varCp
    appendNewInstr $ FinalizeParamCallingDoc varCp block param

  S.TransferTokens ex exm exc ->
    appendNewInstr $ TransferTokens ex exm exc
  S.SetDelegate ex ->
    appendNewInstr $ SetDelegate ex
  S.CreateContract ctrc exk exm exs -> do
    varAddr <- mkNextVar
    appendNewInstr $ CreateContract ctrc exk exm exs varAddr
    return varAddr
  S.SelfCalling proxy ep -> do
    varCR <- mkNextVar
    appendNewInstr $ SelfCalling proxy ep varCR
    return varCR
  S.ContractCalling proxy epRef exAddr -> do
    varMcr <- mkNextVar
    appendNewInstr $ ContractCalling proxy epRef exAddr varMcr
    return varMcr

  S.Fail (_ :: Proxy ret) failure -> do
    appendNewInstr $ Fail failure
    -- Note: because this is a failing instr, this vars are effectively never used
    allocateVars @ret mkNextVar
  S.FailOver (_ :: Proxy ret) failure ex -> do
    appendNewInstr $ FailOver failure ex
    -- Note: because this is a failing instr, this vars are effectively never used
    allocateVars @ret mkNextVar

-- | Continues collecting 'Instruction's from an inner 'IndigoM' (e.g. scoped).
-- This keeps advancing the ref counter as well.
collectInner :: IndigoM ret -> State InstrCollector (ret, Block)
collectInner iM = do
  iColl <- get
  let (ret, InstrCollector newRef block _) = instrCollect (nextRef iColl) (seqHooks iColl) iM
  put $ iColl {nextRef = newRef}
  return (ret, block)

-- | Just a common set of steps used by collection of single-arg lambda's values.
collectInLambda
  :: ScopeCodeGen ret
  => (Var arg -> IndigoM ret)
  -> State InstrCollector (Var arg, Block, ret, RetVars ret)
collectInLambda vIm = do
  var <- mkNextVar
  (ret :: ret, block) <- collectInner $ vIm var
  retVars <- allocateVars @ret mkNextVar
  return (var, block, ret, retVars)

-- | Append a new 'Instruction' to the head of the list in the state.
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
  iColl <- get
  let ref = nextRef iColl
  put $ iColl {nextRef = ref + 1}
  return $ Var ref

-- | Translation from a 'Block' and an initial 'MetaData' to Lorentz.
sequentialToLorentz
  :: MetaData inp
  -> (Block, RefId)
  -> inp :-> inp
sequentialToLorentz md block =
  runSIS (sequentialToSIS block) md St.cleanGenCode

-- | Translation from a 'Block' to a 'SomeIndigoState'.
sequentialToSIS :: (Block, RefId) -> SomeIndigoState inp
sequentialToSIS ([], _) = toSIS St.nopState
sequentialToSIS (x : xs, refId) = instrToSIS refId x `thenSIS` sequentialToSIS (xs, refId)

-- | Translation from a single 'Instruction' to a 'SomeIndigoState'.
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
  SetField vSt lName ex -> toSIS $ setField nextRef vSt lName ex

  LambdaCall1 lKind _lName ex var block ret retVars ->
    withLambdaKind lKind $
      toSIS $ scope (sequentialToSIS (AssignVar var ex : block, nextRef)) ret retVars
  CreateLambda1 lamMd _var body ret varLam ->
    toSIS $ createLambda1Generic varLam ret lamMd (sequentialToSIS (body, nextRef))
  ExecLambda1 lKind (Proxy :: Proxy ret) ex varLam retVars ->
    toSIS $ executeLambda1 @ret lKind nextRef retVars varLam ex

  Scope block ret retVars ->
    toSIS $ scope (sequentialToSIS (block, nextRef)) ret retVars
  If ex blockA retA blockB retB retVars ->
    toSIS $ if_ ex (sequentialToSIS (blockA, nextRef)) retA (sequentialToSIS (blockB, nextRef)) retB retVars
  IfSome ex varX blockA retA blockB retB retVars ->
    toSIS $ ifSome ex varX (sequentialToSIS (blockA, nextRef)) retA (sequentialToSIS (blockB, nextRef)) retB retVars
  IfRight ex varR blockA retA varL blockB retB retVars ->
    toSIS $ ifRight ex varR (sequentialToSIS (blockA, nextRef)) retA varL (sequentialToSIS (blockB, nextRef)) retB retVars
  IfCons ex varX varLX blockA retA blockB retB retVars ->
    toSIS $ ifCons ex varX varLX (sequentialToSIS (blockA, nextRef)) retA (sequentialToSIS (blockB, nextRef)) retB retVars

  Case grd blockClauses retVars ->
    toSIS $ caseRec grd (clausesToBackend nextRef blockClauses) retVars
  EntryCase proxy grd blockClauses retVars ->
    toSIS $ entryCaseRec proxy grd (clausesToBackend nextRef blockClauses) retVars
  EntryCaseSimple grd blockClauses retVars ->
    toSIS $ entryCaseSimpleRec grd (clausesToBackend nextRef blockClauses) retVars

  While ex block ->
    toSIS $ while ex (sequentialToSIS (block, nextRef))
  WhileLeft ex varL block varR ->
    toSIS $ whileLeft ex varL (sequentialToSIS (block, nextRef)) varR
  ForEach ex varIop block ->
    toSIS $ forEach ex varIop (sequentialToSIS (block, nextRef))

  ContractName tx block ->
    contractName tx (sequentialToSIS (block, nextRef))
  DocGroup dg block ->
    docGroup dg (sequentialToSIS (block, nextRef))
  ContractGeneral block ->
    contractGeneral (sequentialToSIS (block, nextRef))
  FinalizeParamCallingDoc varCp block param ->
    finalizeParamCallingDoc varCp (sequentialToSIS (block, nextRef)) param

  TransferTokens ex exm exc ->
    toSIS $ transferTokens ex exm exc
  SetDelegate ex ->
    toSIS $ setDelegate ex
  CreateContract ctrc exk exm exs varAddr ->
    toSIS $ createContract ctrc exk exm exs varAddr
  SelfCalling (Proxy :: Proxy p) ep varCR ->
    toSIS $ selfCalling @p ep varCR
  ContractCalling (Proxy :: Proxy cp) epRef exAddr varMcr ->
    toSIS $ contractCalling @cp epRef exAddr varMcr

  Fail failure -> failure
  FailOver failure ex -> failure ex

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

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

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

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

-- | Convert clauses from their "sequential" representation to the "backend" one.
clausesToBackend
  :: forall ret dt . RMap dt
  => RefId
  -> Rec (IndigoSeqCaseClause ret) dt
  -> Rec (IndigoCaseClauseL ret) dt
clausesToBackend nextRef = rmap $
  \(OneFieldIndigoSeqCaseClause cName (CaseBranch vx block ret)) ->
    cName /-> (IndigoClause vx (sequentialToSIS (block, nextRef)) ret)

-- | Allocate vars for the return value(s) of a clause-like 'Instruction'.
allocateClausesVars
  :: forall ret dt. ReturnableValue ret
  => Rec (S.IndigoMCaseClauseL IndigoM ret) dt
  -> State InstrCollector (RetVars ret)
allocateClausesVars _ = allocateVars @ret mkNextVar

-- | Collects clauses of a case-like statement.
collectClauses
  :: Rec (S.IndigoMCaseClauseL IndigoM ret) dt
  -> State InstrCollector (Rec (IndigoSeqCaseClause ret) dt)
collectClauses RNil = return RNil
collectClauses ((S.OneFieldIndigoMCaseClauseL cName clause) :& xs) = do
  varX <- mkNextVar
  (ret, block) <- collectInner $ clause varX
  let clauseX = OneFieldIndigoSeqCaseClause cName (CaseBranch varX block ret)
  clauseXs <- collectClauses xs
  return $ clauseX :& clauseXs

-- | Applies the given 'Block' to 'Block' transformation to the inner code block
-- of every case clause.
updateClauses
  :: (Block -> Block)
  -> Rec (IndigoSeqCaseClause ret) dt
  -> Rec (IndigoSeqCaseClause ret) dt
updateClauses _ RNil = RNil
updateClauses f (x :& xs) = case x of
  OneFieldIndigoSeqCaseClause cName (CaseBranch vx block ret) ->
    OneFieldIndigoSeqCaseClause cName (CaseBranch vx (f block) ret)
      :& updateClauses f xs

-- | Applies the given monadic function giving it the inner code block of each
-- case clause, in order.
mapMClauses :: Monad m => (Block -> m ()) -> Rec (IndigoSeqCaseClause ret) dt -> m ()
mapMClauses _ RNil = return ()
mapMClauses f (x :& xs) = case x of
  OneFieldIndigoSeqCaseClause _cName (CaseBranch _ block _) ->
    f block >> mapMClauses f xs

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