Error.hs

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

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

-- | Backend failing statements of Indigo.

module Indigo.Backend.Error
  ( failWith
  , never
  , failUsing_
  , failCustom
  , failCustom_
  , failCustomNoArg
  , failUnexpected_
  ) where

import Fmt (Buildable, pretty)

import Indigo.Backend.Expr.Compilation
import Indigo.Backend.Prelude
import Indigo.Common.Expr
import Indigo.Common.State
import Indigo.Common.Var
import Indigo.Lorentz
import Lorentz.Errors qualified as L
import Lorentz.Instr qualified as L

-- | Generic generator of failing 'IndigoState' from failing Lorentz instructions.
failIndigoState :: inp :-> out -> IndigoState inp out
failIndigoState gcCode = iput $ GenCode {..}
  where
    gcStack = FailureStack
    gcClear = L.unit # L.failWith

failWith :: NiceConstant a => Expr a -> IndigoState s t
failWith exa = stmtHookState ("failWith (" <> pretty exa <> ")") $
  exprHookState (pretty exa) (compileExpr exa) >>
  failIndigoState L.failWith

never :: Expr Never -> IndigoState s t
never exa = stmtHookState ("never (" <> pretty exa <> ")") $
  exprHookState (pretty exa) (compileExpr exa) >>
  failIndigoState L.never

failUsing_ :: (IsError x, Buildable x) => x -> IndigoState s t
failUsing_ x = stmtHookState ("failUsing_ (" <> pretty x <> ")") $ failIndigoState (failUsing x)

failCustom
  :: forall tag err s t.
     ( MustHaveErrorArg tag (MText, err)
     , CustomErrorHasDoc tag
     , NiceConstant err
     )
  => Label tag -> Expr err -> IndigoState s t
failCustom l errEx = stmtHookState ("failCustom (" <> pretty errEx <> ")") do
  exprHookState (pretty errEx) (compileExpr errEx)
  failIndigoState $ L.failCustom l

failCustom_
  :: forall tag s t.
     ( MustHaveErrorArg tag (MText, ())
     , CustomErrorHasDoc tag
     )
  => Label tag -> IndigoState s t
failCustom_ = stmtHookState "failCustom_" . failIndigoState . L.failCustom_

failCustomNoArg
  :: forall tag s t.
     ( MustHaveErrorArg tag MText
     , CustomErrorHasDoc tag
     )
  => Label tag -> IndigoState s t
failCustomNoArg = stmtHookState "failCustomNoArg" . failIndigoState . L.failCustomNoArg

failUnexpected_ :: MText -> IndigoState s t
failUnexpected_ msg =
  stmtHookState ("failUnexpected_ (" <> pretty msg <> ")") . failUsing_ $ [mt|Unexpected: |] <> msg