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

-- | Frontend statements's functions of the Indigo Language.

module Indigo.Frontend.Language
  ( -- * Assignment and modifications
    new
  , setVar
  , setField
  , (+=)
  , (-=)
  , (*=)
  , (<<<=)
  , (>>>=)
  , (&&=)
  , (||=)
  , (^=)
  , (=:)

  -- * Storage Fields
  , getStorageField
  , setStorageField
  , updateStorageField

  -- * Conditional
  , if_
  , when
  , unless
  , ifSome
  , ifNone
  , whenSome
  , whenNone
  , ifRight
  , ifLeft
  , whenRight
  , whenLeft
  , ifCons

  -- * Case
  , case_
  , caseRec
  , entryCase
  , entryCaseRec
  , entryCaseSimple
  , (//->)
  , (#=)

  -- * Scope
  , scope
  , defFunction
  , defContract
  , defNamedPureLambda1
  , defNamedLambda1
  , defNamedLambda0
  , defNamedEffLambda1

  -- * Loop
  , while
  , whileLeft
  , forEach

  -- * Contract call
  , selfCalling
  , contractCalling

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

  -- * Short-handed doc item
  , anchor
  , description
  , example

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

  -- * Failures
  , failWith
  , assert
  , failCustom
  , failCustom_
  , failUnexpected_
  , assertCustom
  , assertCustom_
  , assertSome
  , assertNone
  , assertRight
  , assertLeft
  -- * Re-exports
  , ReturnableValue
  , RetVars

  -- * Comments
  , comment
  , justComment
  , commentAroundFun
  , commentAroundStmt

  -- * Blocks
  , IndigoFunction
  , IndigoProcedure
  , IndigoEntrypoint

  -- * Helpers
  , liftIndigoState
  ) where

import Fmt (Buildable)
import GHC.Stack (popCallStack)
import GHC.Stack.Types (SrcLoc(..))

import qualified Indigo.Backend as B
import Indigo.Backend.Case hiding (caseRec, entryCaseRec)
import Indigo.Backend.Lambda
import Indigo.Backend.Scope
import Indigo.Compilation (compileIndigoContract)
import Indigo.Frontend.Program
import Indigo.Frontend.Statement
import Indigo.Internal hiding (SetField, (==), (>>))
import Indigo.Lorentz
import Indigo.Prelude
import Lorentz.Entrypoints.Helpers (RequireSumType)
import qualified Lorentz.Instr as L
import qualified Lorentz.Run as L
import qualified Michelson.Typed as MT
import qualified Michelson.Typed.Arith as M
import Michelson.Typed.Haskell.Instr.Sum (CaseClauseParam(..), CtorField(..))
import Prelude ((==))
import Util.Markdown (toAnchor)
import Util.TypeLits (AppendSymbol)
import Util.TypeTuple.Class

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)

varModification
  :: (IsExpr ey y, IsObject x)
  => ([y, x] :-> '[x]) -> Var x -> ey -> IndigoM ()
varModification act v = oneIndigoM . VarModification act v . toExpr

----------------------------------------------------------------------------
-- Var creation and assignment
----------------------------------------------------------------------------

-- | Create a new variable with the result of the given expression as its initial value.
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, HasCallStack) => Var x -> ex -> IndigoM ()
setVar v = calledFrom . oneIndigoM . SetVar v . toExpr

infixr 0 =:
(=:) :: (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 = 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 ()
(+=) = 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 ()
(-=) = 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 ()
(*=) = 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 ()
(||=) = 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 ()
(&&=) = 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 ()
(^=) = 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 ()
(<<<=) = 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 ()
(>>>=) = calledFrom ... varModification L.lsr

----------------------------------------------------------------------------
-- Storage Fields
----------------------------------------------------------------------------

-- | Sets a storage field to a new value.
setStorageField
  :: forall store name ftype ex.
     ( HasStorage store
     , ex :~> ftype
     , IsObject store
     , IsObject ftype
     , HasField store name ftype
     , HasCallStack
     )
  => Label name -> ex -> IndigoM ()
setStorageField field expr = calledFrom $ setField (storageVar @store) field expr

-- | Updates a storage field by using an updating 'IndigoM'.
updateStorageField
  :: forall store ftype fname fex.
     ( HasStorage store
     , fex :~> ftype
     , HasField store fname ftype
     , IsObject store
     , IsObject ftype
     , HasCallStack
     )
  => Label fname
  -> (Var ftype -> IndigoM fex)
  -> IndigoM ()
updateStorageField field upd = calledFrom $ scope $ do
  let storage = storageVar @store
  fieldVar <- new$ storage #! field
  expr <- upd fieldVar
  setField storage field expr

-- | Get a field from the storage, returns a variable.
--
-- Note that the storage type almost always needs to be specified.
getStorageField
  :: forall store ftype fname .
     ( HasStorage store
     , HasField store fname ftype
     , HasCallStack
     )
  => Label fname -> IndigoM (Var ftype)
getStorageField field = calledFrom $ new$ storageVar @store #! field

----------------------------------------------------------------------------
-- Conditional
----------------------------------------------------------------------------

if_
  :: forall a b ex . (IfConstraint a b, ex :~> Bool, HasCallStack)
  => ex
  -> IndigoM a
  -> IndigoM b
  -> IndigoM (RetVars a)
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, HasCallStack) => exc -> IndigoM () -> IndigoM ()
when cond expr = calledFrom $ if_ cond expr (return ())

-- | Reverse of 'when'.
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, HasCallStack)
  => ex
  -> (Var x -> IndigoM a)
  -> IndigoM b
  -> IndigoM (RetVars a)
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, HasCallStack)
  => ex
  -> IndigoM b
  -> (Var x -> IndigoM a)
  -> IndigoM (RetVars a)
ifNone ex fb tb = calledFrom $ ifSome (toExpr ex) tb fb

-- | Run the instruction when the given expression returns 'Just' a value,
-- do nothing otherwise.
whenSome
  :: forall x exa .
     ( KnownValue x
     , exa :~> Maybe x
     , HasCallStack
     )
  => exa
  -> (Var x -> IndigoM ())
  -> IndigoM ()
whenSome c f = calledFrom $ ifSome c f (return ())

-- | Run the instruction when the given expression returns 'Nothing',
-- do nothing otherwise.
whenNone
  :: forall x exa .
     ( KnownValue x
     , exa :~> Maybe x
     , HasCallStack
     )
  => exa
  -> IndigoM ()
  -> IndigoM ()
whenNone c f = calledFrom $ ifSome c (\_ -> return ()) f

ifRight
  :: forall x y a b ex .
     ( KnownValue x
     , 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 = calledFrom $ oneIndigoM $ IfRight (toExpr ex) rb lb

ifLeft
  :: forall x y a b ex .
     ( KnownValue x
     , 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 = 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 = 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 = calledFrom $ ifRight c (\_ -> return ()) f

ifCons
  :: 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 = calledFrom $ oneIndigoM $ IfCons (toExpr ex) tb fb

----------------------------------------------------------------------------
-- Case
----------------------------------------------------------------------------

-- | A case statement for indigo. See examples for a sample usage.
caseRec
  :: forall dt guard ret clauses .
     ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses
     , guard :~> dt
     , HasCallStack
     )
  => guard
  -> clauses
  -> IndigoM (RetVars ret)
caseRec g = calledFrom . oneIndigoM . Case (toExpr g)

-- | 'caseRec' for tuples.
case_
  :: forall dt guard ret clauses.
     ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses
     , RecFromTuple clauses
     , guard :~> dt
     , HasCallStack
     )
  => guard
  -> IsoRecTuple clauses
  -> IndigoM (RetVars ret)
case_ g = calledFrom . caseRec (toExpr g) . recFromTuple @clauses


-- | 'caseRec' for pattern-matching on parameter.
entryCaseRec
  :: forall dt entrypointKind guard ret clauses .
     ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses
     , DocumentEntrypoints entrypointKind dt
     , guard :~> dt
     , HasCallStack
     )
  => Proxy entrypointKind
  -> guard
  -> clauses
  -> IndigoM (RetVars ret)
entryCaseRec proxy g cls = calledFrom . oneIndigoM $ EntryCase proxy (toExpr g) cls

-- | 'entryCaseRec' for tuples.
entryCase
  :: forall dt entrypointKind guard ret clauses .
     ( CaseCommonF (IndigoMCaseClauseL IndigoM) dt ret clauses
     , RecFromTuple clauses
     , DocumentEntrypoints entrypointKind dt
     , guard :~> dt
     , HasCallStack
     )
  => Proxy entrypointKind
  -> guard
  -> IsoRecTuple clauses
  -> IndigoM (RetVars ret)
entryCase proxy g = calledFrom . entryCaseRec proxy g . recFromTuple @clauses

entryCaseSimple
  :: forall cp guard ret clauses .
     ( CaseCommonF (IndigoMCaseClauseL IndigoM) cp ret clauses
     , RecFromTuple clauses
     , DocumentEntrypoints PlainEntrypointsKind cp
     , NiceParameterFull cp
     , RequireFlatParamEps cp
     , guard :~> cp
     , HasCallStack
     )
  => guard
  -> IsoRecTuple clauses
  -> IndigoM (RetVars ret)
entryCaseSimple g = calledFrom . oneIndigoM . EntryCaseSimple (toExpr g) . recFromTuple @clauses

{-# DEPRECATED (//->) "use '#=' instead" #-}
-- | An alias for '#=' kept only for backward compatibility.
(//->)
  :: ( name ~ (AppendSymbol "c" ctor)
     , KnownValue x
     , ScopeCodeGen retBr
     , ret ~ RetExprs retBr
     , RetOutStack ret ~ RetOutStack retBr
     )
  => Label name
  -> (Var x -> IndigoM retBr)
  -> IndigoMCaseClauseL IndigoM ret ('CaseClauseParam ctor ('OneField x))
(//->) cName b = OneFieldIndigoMCaseClauseL cName b
infixr 0 //->

-- | Use this instead of '/->'.
--
-- This operator is like '/->' but wraps a body into 'IndigoAnyOut',
-- which is needed for two reasons: to allow having any output stack
-- and to allow returning not exactly the same values.
--
-- It has the added benefit of not being an arrow, so in case the body of the
-- clause is a lambda there won't be several.
(#=)
  :: ( name ~ (AppendSymbol "c" ctor)
     , KnownValue x
     , ScopeCodeGen retBr
     , ret ~ RetExprs retBr
     , RetOutStack ret ~ RetOutStack retBr
     )
  => Label name
  -> (Var x -> IndigoM retBr)
  -> IndigoMCaseClauseL IndigoM ret ('CaseClauseParam ctor ('OneField x))
(#=) cName b = OneFieldIndigoMCaseClauseL cName b
infixr 0 #=

----------------------------------------------------------------------------
-- Scope & Functions
----------------------------------------------------------------------------

-- | Utility type for an 'IndigoM' that adds one element to the stack and returns
-- a variable pointing at it.
type IndigoFunction ret = IndigoM (RetVars ret)

-- | Utility type for an 'IndigoM' that does not modify the stack (only the
-- values in it) and returns nothing.
type IndigoProcedure = IndigoM ()

type IndigoEntrypoint param = param -> IndigoProcedure

scope
  :: forall a . (ScopeCodeGen a, HasCallStack)
  => IndigoM a
  -> IndigoFunction a
scope = calledFrom . oneIndigoM . Scope

-- | Alias for 'scope' we use in the tutorial.
defFunction
  :: forall a . (ScopeCodeGen a, HasCallStack)
  => IndigoM a
  -> IndigoFunction a
defFunction = calledFrom . scope

-- | A more specific version of 'defFunction' meant to more easily create
-- 'IndigoContract's.
--
-- Used in the tutorial. The 'HasSideEffects' constraint is
-- specified to avoid the warning for redundant constraints.
defContract
  :: HasCallStack
  => (HasSideEffects => IndigoM ())
  -> (HasSideEffects => IndigoProcedure)
defContract = calledFrom . scope

-- | Family of @defNamed*LambdaN@ functions put an Indigo computation
-- on the stack to later call it avoiding code duplication.
-- @defNamed*LambdaN@ takes a computation with N arguments.
-- This family of functions add some overhead to contract byte size
-- for every call of the function,
-- therefore, DON'T use @defNamed*LambdaN@ if:
-- * Your computation is pretty small.
--   It would be cheaper just to inline it, so use 'defFunction'.
-- * Your computation is called only once, in this case also use 'defFunction'.
--
-- Also, pay attention that @defNamed*LambdaN@ accepts a string that is
-- a name of the passed computation. Be careful and make sure that all
-- declared computations have different names.
-- Later the name will be removed.
--
-- Pay attention, that lambda argument will be evaluated
-- to variable before lambda calling.
--
-- TODO Approach with lambda names has critical pitfall:
-- in case if a function takes @Label name@, lambda body
-- won't be regenerated for every different label.
-- So be carefully, this will be fixed in a following issue.
defNamedEffLambda1
  :: forall st argExpr res .
  ( ToExpr argExpr
  , 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 ->
  calledFrom $ oneIndigoM $ LambdaCall1 (EffLambda (Proxy @st)) lName body (toExpr ex)

-- | Like defNamedEffLambda1 but doesn't make side effects.
defNamedLambda1
  :: forall st argExpr res .
  ( ToExpr argExpr
  , Typeable res
  , ExecuteLambda1C st (ExprType argExpr) res
  , CreateLambda1C st (ExprType argExpr) res
  , HasCallStack
  )
  => String
  -> (Var (ExprType argExpr) -> IndigoM res)
  -> (argExpr -> IndigoM (RetVars res))
defNamedLambda1 lName body = \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
  , HasCallStack
  )
  => String
  -> IndigoM res
  -> IndigoM (RetVars res)
defNamedLambda0 lName body =
  calledFrom $ oneIndigoM $ LambdaCall1 (StorageLambda (Proxy @st)) lName (\(_ :: Var ()) -> body) (C ())

-- | Like defNamedEffLambda1 but doesn't modify storage and doesn't make side effects.
defNamedPureLambda1
  :: forall argExpr res .
  ( ToExpr argExpr
  , Typeable res
  , ExecuteLambdaPure1C (ExprType argExpr) res
  , CreateLambdaPure1C (ExprType argExpr) res
  , HasCallStack
  )
  => String
  -> (Var (ExprType argExpr) -> IndigoM res)
  -> (argExpr -> IndigoM (RetVars res))
defNamedPureLambda1 lName body = \ex ->
  calledFrom $ oneIndigoM $ LambdaCall1 PureLambda lName body (toExpr ex)

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

-- | While statement.
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 = calledFrom $ oneIndigoM $ WhileLeft (toExpr e) body

-- | For statements to iterate over a container.
forEach
  :: forall a e . (IterOpHs a, KnownValue (IterOpElHs a), e :~> a, HasCallStack)
  => e -> (Var (IterOpElHs a) -> IndigoM ())
  -> IndigoM ()
forEach container body = calledFrom $ oneIndigoM $ ForEach (toExpr container) body

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

-- | Put a document item.
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 :: (DocItem di, HasCallStack) => (SubDoc -> di) -> IndigoM () -> IndigoM ()
docGroup = calledFrom . oneIndigoM ... DocGroup

-- | Insert documentation of the contract's storage type. The type
-- should be passed using type applications.
{-# DEPRECATED docStorage "Use `doc (dStorage @storage)` instead." #-}
docStorage :: forall storage. (TypeHasDoc storage, HasCallStack) => IndigoM ()
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 :: HasCallStack => Text -> IndigoM () -> IndigoM ()
contractName = docGroup . DName

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

-- | Attach default general info to the contract documentation.
contractGeneralDefault :: HasCallStack => IndigoM ()
contractGeneralDefault = calledFrom $ liftIndigoState $ toSIS $ B.contractGeneralDefault

-- | Indigo version for the homonym Lorentz function.
finalizeParamCallingDoc
  :: forall param.
     ( ToExpr param
     , NiceParameterFull (ExprType param)
     , RequireSumType (ExprType param)
     , HasCallStack
     )
  => (Var (ExprType param) -> IndigoM ()) -> param -> IndigoM ()
finalizeParamCallingDoc i = calledFrom . oneIndigoM . FinalizeParamCallingDoc i . toExpr

-- | Put a 'DDescription' doc item.
description :: HasCallStack => Markdown -> IndigoM ()
description = calledFrom . doc . DDescription

-- | Put a 'DAnchor' doc item.
anchor :: HasCallStack => Text -> IndigoM ()
anchor = calledFrom . doc . DAnchor . toAnchor

-- | Put a 'DEntrypointExample' doc item.
example :: forall a. (NiceParameter a, HasCallStack) => a -> IndigoM ()
example = calledFrom . doc . mkDEntrypointExample

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

selfCalling
  :: forall p mname.
     ( NiceParameterFull p
     , KnownValue (GetEntrypointArgCustom p mname)
     , HasCallStack
     )
  => EntrypointRef mname
  -> IndigoM (Var (ContractRef (GetEntrypointArgCustom p mname)))
selfCalling = calledFrom . oneIndigoM ... SelfCalling (Proxy @p)

contractCalling
  :: forall cp epRef epArg addr exAddr.
     ( HasEntrypointArg cp epRef epArg
     , ToTAddress cp addr
     , ToT addr ~ ToT Address
     , exAddr :~> addr
     , KnownValue epArg
     , HasCallStack
     )
  => epRef -> exAddr -> IndigoM (Var (Maybe (ContractRef epArg)))
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
     , HasCallStack
     )
  => exp -> exm -> exc -> IndigoM ()
transferTokens ep em ec = calledFrom $ oneIndigoM $
  TransferTokens (toExpr ep) (toExpr em) (toExpr ec)

setDelegate :: (HasSideEffects, IsExpr ex (Maybe KeyHash), HasCallStack) => ex -> IndigoM ()
setDelegate = calledFrom . oneIndigoM . SetDelegate . toExpr

-- | Create contract using default compilation options for Lorentz compiler.
--
-- See "Lorentz.Run".
createContract
  :: ( IsObject st
     , 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 = 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'.
createLorentzContract
  :: ( IsObject st
     , 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 = calledFrom $ oneIndigoM $
  CreateContract lCtr (toExpr ek) (toExpr em) (toExpr es)

----------------------------------------------------------------------------
-- Error
----------------------------------------------------------------------------

failWith
  :: forall ret a ex . (IsExpr ex a, ReturnableValue ret, HasCallStack)
  => ex -> IndigoM (RetVars ret)
failWith = calledFrom . oneIndigoM . FailOver (Proxy @ret) (toSIS . B.failWith) . toExpr

failUsing_
  :: forall ret x. (IsError x, Buildable x, ReturnableValue ret, HasCallStack)
  => x -> IndigoM (RetVars ret)
failUsing_ x = calledFrom $ oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failUsing_ x)

failCustom
  :: forall ret tag err ex.
     ( ReturnableValue ret
     , err ~ ErrorArg tag
     , CustomErrorHasDoc tag
     , NiceConstant err
     , ex :~> err
     , HasCallStack
     )
  => Label tag -> ex -> IndigoM (RetVars ret)
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 = calledFrom $ oneIndigoM $ Fail (Proxy @ret) (toSIS $ B.failCustom_ tag)

failUnexpected_
  :: forall ret. (ReturnableValue ret, HasCallStack)
  => MText -> IndigoM (RetVars ret)
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 = calledFrom $ if_ ex (return ()) (failUsing_ @() err)

assertCustom
  :: forall tag err errEx ex .
     ( err ~ ErrorArg tag
     , CustomErrorHasDoc tag
     , NiceConstant err
     , IsExpr errEx err
     , IsExpr ex Bool
     , HasCallStack
     )
  => Label tag -> errEx -> ex -> IndigoM ()
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 = 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 = 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 = 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 = 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 = calledFrom $ ifRight ex (\_ -> return ()) (\_ -> failUsing_ @() err)

----------------------------------------------------------------------------
-- Comments
----------------------------------------------------------------------------

-- | Add a comment in a generated Michelson code
justComment :: HasCallStack => Text -> IndigoM ()
justComment = calledFrom . comment . MT.JustComment

-- | Add a comment in a generated Michelson code
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 :: 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 :: HasCallStack => Text -> IndigoM a -> IndigoM a
commentAroundStmt sName body = calledFrom $
  comment (MT.StatementStarts sName) >>
  body >>=
  \res -> res <$ comment (MT.StatementEnds sName)