Conditional.hs

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

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

-- | Backend conditional statements of Indigo

module Indigo.Backend.Conditional
  ( if_
  , ifSome
  , ifRight
  , ifCons
  , IfConstraint
  ) where

import qualified Data.Kind as Kind
import qualified GHC.TypeLits as Lit
import Util.Type (type (++))

import Indigo.Backend.Prelude
import Indigo.Backend.Scope
import Indigo.Internal
import Indigo.Lorentz
import qualified Lorentz.Instr as L
import qualified Lorentz.Macro as L

type family CompareBranchesResults (a :: Kind.Type) (b :: Kind.Type) :: Constraint where
  CompareBranchesResults x x = ()
  CompareBranchesResults x y = Lit.TypeError
      ('Lit.Text " Result types of if branches diverged: "
       'Lit.:<>: 'Lit.ShowType x 'Lit.:<>: ('Lit.Text " against ") 'Lit.:<>: 'Lit.ShowType y
      )

type IfConstraint a b =
  ( ScopeCodeGen a
  , ScopeCodeGen b
  , CompareBranchesResults (RetExprs a) (RetExprs b)
  -- These constraints below are implied by the one above, but GHC needs a proof
  , RetVars a ~ RetVars b
  , RetOutStack a ~ RetOutStack b
  )

-- | If statement. All variables created inside its branches will be released
-- after the execution leaves the scope in which they were created.
if_
  :: forall inp a b . IfConstraint a b
  => Expr Bool
  -- ^ Expression for the control flow
  -> SomeIndigoState inp
  -- ^ Code block for the positive branch
  -> a
  -- ^ Return value(s) of the positive branch
  -> SomeIndigoState inp
  -- ^ 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)
  -> IndigoState inp (RetOutStack a ++ inp)
if_ e t retA f retB retVars = IndigoState $ \md@MetaData{..} ->
  let cde = gcCode $ usingIndigoState md (compileExpr e) in
  runSIS t md $ \gc1 ->
    runSIS f md $ \gc2 ->
      finalizeStatement @a mdStack retVars $
        cde # L.if_ (compileScope @a mdObjects gc1 retA) (compileScope @b mdObjects gc2 retB)

-- | If which works like case for Maybe.
ifSome
  :: forall inp x a b . (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)
  -> SomeIndigoState (x & inp)
  -- ^ Code block for the 'Just' branch
  -> a
  -- ^ Return value(s) of the 'Just' branch
  -> SomeIndigoState inp
  -- ^ 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)
  -> IndigoState inp (RetOutStack a ++ inp)
ifSome e varX t retA f retB retVars = IndigoState $ \md@MetaData{..} ->
  let cde = gcCode $ usingIndigoState md (compileExpr e) in
  let mdJust = pushRefMd varX md in
  runSIS t mdJust $ \gc1 ->
    runSIS f md $ \gc2 ->
      finalizeStatement @a mdStack retVars $
        cde #
        L.ifSome
          ( compileScope @a mdObjects gc1 retA #
            -- after this we have stack (e1 & e2 .. & ek & x & inp)
            liftClear' @(ClassifyReturnValue a) @a @(x & inp) @inp L.drop
            -- this can be lifted together with glClear code, but let's leave it like this for now
          )
          (compileScope @b mdObjects gc2 retB)

-- | If which works like case for Either.
ifRight
  :: forall inp r l a b . (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)
  -> SomeIndigoState (r & inp)
  -- ^ 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)
  -> SomeIndigoState (l & inp)
  -- ^ 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)
  -> IndigoState inp (RetOutStack a ++ inp)
ifRight e varR r retA varL l retB retVars = IndigoState $ \md@MetaData{..} ->
  let
    cde = gcCode $ usingIndigoState md (compileExpr e)
    mdRight = pushRefMd varR md
    mdLeft = pushRefMd varL md
  in
    runSIS r mdRight $ \gc1 ->
      runSIS l mdLeft $ \gc2 ->
        finalizeStatement @a mdStack retVars $
          cde #
          L.ifRight
            ( compileScope @a mdObjects gc1 retA #
            -- after this we have stack (e1 & e2 .. & ek & x & inp)
            liftClear' @(ClassifyReturnValue a) @a @(r & inp) @inp L.drop
            -- this can be lifted together with glClear code, but let's leave it like this for now
            )
            ( compileScope @b mdObjects gc2 retB #
            -- after this we have stack (e1 & e2 .. & ek & x & inp)
            liftClear' @(ClassifyReturnValue b) @b @(l & inp) @inp L.drop
            -- this can be lifted together with glClear code, but let's leave it like this for now
            )

-- | If which works like uncons for lists.
ifCons
  :: forall inp x a b . (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)
  -> SomeIndigoState (x & List x & inp)
  -- ^ Code block for the non-empty list branch
  -> a
  -- ^ Return value(s) of the non-empty list branch
  -> SomeIndigoState inp
  -- ^ 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)
  -> IndigoState inp (RetOutStack a ++ inp)
ifCons e vx vlx t retA f retB retVars = IndigoState $ \md@MetaData{..} ->
  let
    cde = gcCode $ usingIndigoState md (compileExpr e)
    mdList = pushRefMd vlx md
    mdVal = pushRefMd vx mdList
  in
    runSIS t mdVal $ \gc1 ->
      runSIS f md $ \gc2 ->
        finalizeStatement @a mdStack retVars $
          cde #
          L.ifCons
            ( compileScope @a mdObjects gc1 retA #
              liftClear' @(ClassifyReturnValue a) @a @(x & List x & inp) @inp (L.drop # L.drop)
            )
            (compileScope @b mdObjects gc2 retB)