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

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

-- | Machinery that provides the ability to return values from Indigo statements
-- (like @if@, @case@, @while@, etc).
-- You are allowed to return unit, one expression or a tuple of expressions.
-- For instance:
--
-- @
-- (a, b) <- if flag
--           then do
--                  anotherFlag <- newVar True
--                  return (5 +. var, anotherFlag ||. True)
--           else return (0, anotherVar)
-- @
-- is a valid construction.
-- Pay attention to the fact that @5 +. var@ has the type 'Expr' 'Integer',
-- but 0 is just an 'Integer' and @anotherFlag ||. True@ has type 'Expr' 'Bool',
-- but @anotherVar@ has type 'Var' 'Bool'; and this code will compile anyway.
-- This is done intentionally to avoid the burden of manually converting values
-- to expressions (or variables).
-- So you can write the same constructions as in a regular language.

module Indigo.Backend.Scope
  ( BranchRetKind (..)
  , ScopeCodeGen
  , ScopeCodeGen' (..)
  , ReturnableValue
  , ReturnableValue' (..)
  , RetOutStack
  , RetVars
  , RetExprs
  , ClassifyReturnValue
  , liftClear
  , compileScope
  , allocateVars
  , finalizeStatement

  -- Builder helpers for hooks
  , prettyAssign
  , condStmtPretty
  , prettyRet
  ) where

import qualified Data.Kind as Kind
import Fmt (Buildable(..), pretty)
import qualified GHC.TypeLits as Lit
import Util.Type (type (++))

import Indigo.Backend.Prelude
import Indigo.Internal.Expr hiding ((<>))
import Indigo.Internal.State
import Indigo.Internal.Var
import Indigo.Lorentz
import qualified Lorentz.Instr as L

-- | To avoid overlapping instances we need to somehow distinguish single values
-- from tuples, because the instances:
--
-- @
--   instance Something a
--   instance Something (a, b)
-- @
-- overlap and adding @&#x7b;-\# OVERLAPPING \#-&#x7d;@ doesn't rescue in some cases,
-- especially for type families defined in @Something@.
data BranchRetKind =
    Unit
  -- ^ If value is unit (don't return anything)
  | SingleVal
  -- ^ If it's a single value (not tuple)
  | Tuple
  -- ^ If it's tuple (we don't care how many elements are in)

-- | This type family returns a promoted value of type 'BranchRetKind'
-- or causes a compilation error if a tuple with too many elements is used.
type family ClassifyReturnValue (ret :: Kind.Type) where
  ClassifyReturnValue ()     = 'Unit
  ClassifyReturnValue (_, _) = 'Tuple
  -- These type errors are an attempt to make compilation errors clear
  -- in cases where one tries to return a tuple with more elements from a statement
  ClassifyReturnValue (_, _, _) = 'Tuple
  ClassifyReturnValue (_, _, _, _) =
    Lit.TypeError ('Lit.Text "Tuple with 4 elements is not supported yet as returning value")
  ClassifyReturnValue (_, _, _, _, _) =
    Lit.TypeError ('Lit.Text "Tuple with 5 elements is not supported yet as returning value")
  ClassifyReturnValue (_, _, _, _, _, _) =
    Lit.TypeError ('Lit.Text "Tuple with 6 elements is not supported yet as returning value")
  -- I hope nobody will try to return as a value tuples with more elements
  ClassifyReturnValue _      = 'SingleVal

-- | Class for values that can be returned from Indigo statements.
-- They include @()@ and tuples.
class ReturnableValue' (retKind :: BranchRetKind) (ret :: Kind.Type) where
  -- | Type family reflecting the top elements of stack produced by
  -- a statement returning the value.
  type family RetOutStack' retKind ret :: [Kind.Type]

  -- | Type family reflecting the returning value from a statement.
  type family RetVars' retKind ret :: Kind.Type

  -- | Tuple looking like @(Expr x, Expr y, ..)@ that corresponds
  -- to expressions returning from the scope.
  -- 'RetVars\'' and 'RetExprs\'' are twin types because
  -- the former just adds 'Var' over each expression of the latter.
  type family RetExprs' retKind ret :: Kind.Type

  -- | Allocate variables referring to result of the statement.
  -- Requires an allocator operating in a Monad.
  allocateVars'
    :: Monad m
    => (forall (x :: Kind.Type) . m (Var x))
    -> m (RetVars' retKind ret)

  -- | Push the variables referring to the result of the statement on top of
  -- the stack of the given 'StackVars'.
  assignVars'
    :: RetVars' retKind ret
    -> StackVars inp
    -> StackVars (RetOutStack' retKind ret ++ inp)

  -- | Pretty printing of statements like \"var := statement\"
  prettyAssign' :: RetVars' retKind ret -> Text -> Text

  -- | Prettify 'ret' value
  prettyRet' :: ret -> Text

-- | Type class which unions all related management of computations in a scope,
-- like in @if@ branch, in @case@ body, etc.
--
-- Particularly, it takes care of the computation of expressions returning
-- from a scope to leave it safely.
-- Basically, this type class encapsulates the generation of Lorentz code that looks like:
--
-- @
--   branch_code #
--     -- we get some arbitrary type of a stack here, lets call it @xs@
--   compute_returning_expressions #
--     -- we get type of stack [e1, e2, ... ek] ++ xs
--   cleanup_xs_to_inp
--     -- we get [e1, e2, e3, ..., ek] ++ inp
-- @
class ReturnableValue' retKind ret => ScopeCodeGen' (retKind :: BranchRetKind) (ret :: Kind.Type) where
  -- | Produces an Indigo computation that puts on the stack
  -- the evaluated returned expressions from the leaving scope.
  compileScopeReturn' :: ret -> IndigoState xs (RetOutStack' retKind ret ++ xs)

  -- | Drop the stack cells that were produced in the leaving scope,
  -- apart from ones corresponding to the returning expressions.
  liftClear' :: (xs :-> inp) -> (RetOutStack' retKind ret ++ xs :-> RetOutStack' retKind ret ++ inp)

  -- | Generate 'gcClear' for the whole statement
  genGcClear' :: (RetOutStack' retKind ret ++ inp) :-> inp

type RetOutStack ret = RetOutStack' (ClassifyReturnValue ret) ret
type RetVars ret = RetVars' (ClassifyReturnValue ret) ret
type RetExprs ret = RetExprs' (ClassifyReturnValue ret) ret
type ReturnableValue ret = ReturnableValue' (ClassifyReturnValue ret) ret
type ScopeCodeGen ret = ScopeCodeGen' (ClassifyReturnValue ret) ret

-- | Specific version of 'allocateVars\''
allocateVars
  :: forall ret m . (ReturnableValue ret, Monad m)
  => (forall (x :: Kind.Type) . m (Var x))
  -> m (RetVars ret)
allocateVars :: (forall x. m (Var x)) -> m (RetVars ret)
allocateVars = forall (m :: * -> *).
(ReturnableValue' (ClassifyReturnValue ret) ret, Monad m) =>
(forall x. m (Var x)) -> m (RetVars ret)
forall (retKind :: BranchRetKind) ret (m :: * -> *).
(ReturnableValue' retKind ret, Monad m) =>
(forall x. m (Var x)) -> m (RetVars' retKind ret)
allocateVars' @(ClassifyReturnValue ret) @ret

-- | Specific version of 'liftClear\''
liftClear
  :: forall ret inp xs . ScopeCodeGen ret
  => (xs :-> inp)
  -> (RetOutStack ret ++ xs :-> RetOutStack ret ++ inp)
liftClear :: (xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
liftClear = forall (xs :: [*]) (inp :: [*]).
ScopeCodeGen' (ClassifyReturnValue ret) ret =>
(xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
forall (retKind :: BranchRetKind) ret (xs :: [*]) (inp :: [*]).
ScopeCodeGen' retKind ret =>
(xs :-> inp)
-> (RetOutStack' retKind ret ++ xs)
   :-> (RetOutStack' retKind ret ++ inp)
liftClear' @(ClassifyReturnValue ret) @ret

prettyAssign :: forall ret . ReturnableValue ret => RetVars ret -> Text -> Text
prettyAssign :: RetVars ret -> Text -> Text
prettyAssign = ReturnableValue' (ClassifyReturnValue ret) ret =>
RetVars ret -> Text -> Text
forall (retKind :: BranchRetKind) ret.
ReturnableValue' retKind ret =>
RetVars' retKind ret -> Text -> Text
prettyAssign' @(ClassifyReturnValue ret) @ret

prettyRet :: forall ret . ReturnableValue ret => ret -> Text
prettyRet :: ret -> Text
prettyRet = ReturnableValue' (ClassifyReturnValue ret) ret => ret -> Text
forall (retKind :: BranchRetKind) ret.
ReturnableValue' retKind ret =>
ret -> Text
prettyRet' @(ClassifyReturnValue ret) @ret

condStmtPretty :: forall ret x . ReturnableValue ret => RetVars ret -> Text -> Expr x -> Text
condStmtPretty :: RetVars ret -> Text -> Expr x -> Text
condStmtPretty retVars :: RetVars ret
retVars stmtName :: Text
stmtName ex :: Expr x
ex = RetVars ret -> Text -> Text
forall ret. ReturnableValue ret => RetVars ret -> Text -> Text
prettyAssign @ret RetVars ret
retVars (Text
stmtName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr x -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Expr x
ex Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")

-- | Concatenate a scoped code, generation of returning expressions,
-- and clean up of redundant cells from the stack.
compileScope
  :: forall ret inp xs . ScopeCodeGen ret
  => (StackVars xs -> MetaData xs)
  -- ^ Partially applied constructor of 'MetaData' (without passed 'StackVars').
  -- 'compileScope' function is usually being called from another function
  -- which is in 'IndigoState' and, consequently, holding 'MetaData' with all fields.
  -> GenCode inp xs
  -- ^ Code (and clear) of a wrapping scope
  -> ret
  -- ^ Return value of a scope (either primitives or expressions or variables)
  -> (inp :-> RetOutStack ret ++ inp)
compileScope :: (StackVars xs -> MetaData xs)
-> GenCode inp xs -> ret -> inp :-> (RetOutStack ret ++ inp)
compileScope mdCr :: StackVars xs -> MetaData xs
mdCr innerGc :: GenCode inp xs
innerGc gcRet :: ret
gcRet =
  let md :: MetaData xs
md = StackVars xs -> MetaData xs
mdCr (GenCode inp xs -> StackVars xs
forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack GenCode inp xs
innerGc) in
  GenCode inp xs -> inp :-> xs
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode GenCode inp xs
innerGc (inp :-> xs)
-> (xs :-> (RetOutStack ret ++ xs))
-> inp :-> (RetOutStack ret ++ xs)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  MetaData xs
-> Text
-> (xs :-> (RetOutStack ret ++ xs))
-> xs :-> (RetOutStack ret ++ xs)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData xs
md ("computation of returning values: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ret -> Text
forall ret. ReturnableValue ret => ret -> Text
prettyRet ret
gcRet)
    (GenCode xs (RetOutStack ret ++ xs)
-> xs :-> (RetOutStack ret ++ xs)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode xs (RetOutStack ret ++ xs)
 -> xs :-> (RetOutStack ret ++ xs))
-> GenCode xs (RetOutStack ret ++ xs)
-> xs :-> (RetOutStack ret ++ xs)
forall a b. (a -> b) -> a -> b
$ MetaData xs
-> IndigoState xs (RetOutStack ret ++ xs)
-> GenCode xs (RetOutStack ret ++ xs)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData xs
md (IndigoState xs (RetOutStack ret ++ xs)
 -> GenCode xs (RetOutStack ret ++ xs))
-> IndigoState xs (RetOutStack ret ++ xs)
-> GenCode xs (RetOutStack ret ++ xs)
forall a b. (a -> b) -> a -> b
$ ret -> IndigoState xs (RetOutStack ret ++ xs)
forall (retKind :: BranchRetKind) ret (xs :: [*]).
ScopeCodeGen' retKind ret =>
ret -> IndigoState xs (RetOutStack' retKind ret ++ xs)
compileScopeReturn' @(ClassifyReturnValue ret) ret
gcRet) (inp :-> (RetOutStack ret ++ xs))
-> ((RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp))
-> inp :-> (RetOutStack ret ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  MetaData xs
-> Text
-> ((RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp))
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData xs
md "dropping cells from the stack allocated in the scope"
    ((xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
forall (retKind :: BranchRetKind) ret (xs :: [*]) (inp :: [*]).
ScopeCodeGen' retKind ret =>
(xs :-> inp)
-> (RetOutStack' retKind ret ++ xs)
   :-> (RetOutStack' retKind ret ++ inp)
liftClear' @(ClassifyReturnValue ret) @ret (GenCode inp xs -> xs :-> inp
forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear GenCode inp xs
innerGc))

-- | Push variables in the 'StackVars', referring to the generated expressions,
-- and generate 'gcClear' for the whole statement.
finalizeStatement
  :: forall ret inp . ScopeCodeGen ret
  => StackVars inp
  -> RetVars ret
  -> (inp :-> RetOutStack ret ++ inp)
  -> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement :: StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement md :: StackVars inp
md vars :: RetVars ret
vars code :: inp :-> (RetOutStack ret ++ inp)
code =
  let newMd :: StackVars (RetOutStack ret ++ inp)
newMd = RetVars ret -> StackVars inp -> StackVars (RetOutStack ret ++ inp)
forall (retKind :: BranchRetKind) ret (inp :: [*]).
ReturnableValue' retKind ret =>
RetVars' retKind ret
-> StackVars inp -> StackVars (RetOutStack' retKind ret ++ inp)
assignVars' @(ClassifyReturnValue ret) @ret RetVars ret
vars StackVars inp
md in
  StackVars (RetOutStack ret ++ inp)
-> (inp :-> (RetOutStack ret ++ inp))
-> ((RetOutStack ret ++ inp) :-> inp)
-> GenCode inp (RetOutStack ret ++ inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars (RetOutStack ret ++ inp)
newMd inp :-> (RetOutStack ret ++ inp)
code (forall (inp :: [*]).
ScopeCodeGen' (ClassifyReturnValue ret) ret =>
(RetOutStack ret ++ inp) :-> inp
forall (retKind :: BranchRetKind) ret (inp :: [*]).
ScopeCodeGen' retKind ret =>
(RetOutStack' retKind ret ++ inp) :-> inp
genGcClear' @(ClassifyReturnValue ret) @ret)

-- Type instances for ScopeCodeGen'.
-- Perhaps, they could be implemented more succinctly
-- and expressed inductively via previous instances,
-- but I don't think it makes sense to spend a lot of time to shorten them.

type KnownValueExpr a = (KnownValue (ExprType a), ToExpr a)

instance ReturnableValue' 'Unit () where
  type RetOutStack' 'Unit () = '[]
  type RetVars' 'Unit () = ()
  type RetExprs' 'Unit () = ()
  allocateVars' :: (forall x. m (Var x)) -> m (RetVars' 'Unit ())
allocateVars' _ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  assignVars' :: RetVars' 'Unit ()
-> StackVars inp -> StackVars (RetOutStack' 'Unit () ++ inp)
assignVars' _ md :: StackVars inp
md = StackVars inp
StackVars (RetOutStack' 'Unit () ++ inp)
md
  prettyAssign' :: RetVars' 'Unit () -> Text -> Text
prettyAssign' _ stmt :: Text
stmt = Text
stmt
  prettyRet' :: () -> Text
prettyRet' _ = "()"

instance ScopeCodeGen' 'Unit () where
  compileScopeReturn' :: () -> IndigoState xs (RetOutStack' 'Unit () ++ xs)
compileScopeReturn' _ = IndigoState xs (RetOutStack' 'Unit () ++ xs)
forall (inp :: [*]). IndigoState inp inp
nopState
  liftClear' :: (xs :-> inp)
-> (RetOutStack' 'Unit () ++ xs) :-> (RetOutStack' 'Unit () ++ inp)
liftClear' = (xs :-> inp)
-> (RetOutStack' 'Unit () ++ xs) :-> (RetOutStack' 'Unit () ++ inp)
forall a. a -> a
id
  genGcClear' :: (RetOutStack' 'Unit () ++ inp) :-> inp
genGcClear' = (RetOutStack' 'Unit () ++ inp) :-> inp
forall (s :: [*]). s :-> s
L.nop

instance KnownValueExpr single => ReturnableValue' 'SingleVal single where
  type RetOutStack' 'SingleVal single = '[ExprType single]
  type RetVars' 'SingleVal single = Var (ExprType single)
  type RetExprs' 'SingleVal single = ExprType single
  allocateVars' :: (forall x. m (Var x)) -> m (RetVars' 'SingleVal single)
allocateVars' allocator :: forall x. m (Var x)
allocator = m (Var (ExprType single))
forall x. m (Var x)
allocator @(ExprType single)
  assignVars' :: RetVars' 'SingleVal single
-> StackVars inp
-> StackVars (RetOutStack' 'SingleVal single ++ inp)
assignVars' = RetVars' 'SingleVal single
-> StackVars inp
-> StackVars (RetOutStack' 'SingleVal single ++ inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef
  prettyAssign' :: RetVars' 'SingleVal single -> Text -> Text
prettyAssign' retVars :: RetVars' 'SingleVal single
retVars stmt :: Text
stmt = Var (ExprType single) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Var (ExprType single)
RetVars' 'SingleVal single
retVars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " := " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stmt
  prettyRet' :: single -> Text
prettyRet' = Expr (ExprType single) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Expr (ExprType single) -> Text)
-> (single -> Expr (ExprType single)) -> single -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. single -> Expr (ExprType single)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr

instance KnownValueExpr single => ScopeCodeGen' 'SingleVal single where
  compileScopeReturn' :: single -> IndigoState xs (RetOutStack' 'SingleVal single ++ xs)
compileScopeReturn' = single -> IndigoState xs (RetOutStack' 'SingleVal single ++ xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr
  liftClear' :: (xs :-> inp)
-> (RetOutStack' 'SingleVal single ++ xs)
   :-> (RetOutStack' 'SingleVal single ++ inp)
liftClear' = (xs :-> inp)
-> (RetOutStack' 'SingleVal single ++ xs)
   :-> (RetOutStack' 'SingleVal single ++ inp)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
  genGcClear' :: (RetOutStack' 'SingleVal single ++ inp) :-> inp
genGcClear' = (RetOutStack' 'SingleVal single ++ inp) :-> inp
forall a (s :: [*]). (a : s) :-> s
L.drop

instance ( KnownValueExpr x
         , KnownValueExpr y
         , Buildable (RetVars' 'Tuple (x, y))
         )
         => ReturnableValue' 'Tuple (x, y) where
  type RetOutStack' 'Tuple (x, y) = ExprType x ': '[ExprType y]
  type RetVars' 'Tuple (x, y) = (Var (ExprType x), Var (ExprType y))
  type RetExprs' 'Tuple (x, y) = (ExprType x, ExprType y)
  allocateVars' :: (forall x. m (Var x)) -> m (RetVars' 'Tuple (x, y))
allocateVars' allocator :: forall x. m (Var x)
allocator = (,) (Var (ExprType' (Decide x) x)
 -> Var (ExprType' (Decide y) y)
 -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y)))
-> m (Var (ExprType' (Decide x) x))
-> m (Var (ExprType' (Decide y) y)
      -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Var (ExprType' (Decide x) x))
forall x. m (Var x)
allocator m (Var (ExprType' (Decide y) y)
   -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y)))
-> m (Var (ExprType' (Decide y) y))
-> m (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Var (ExprType' (Decide y) y))
forall x. m (Var x)
allocator
  assignVars' :: RetVars' 'Tuple (x, y)
-> StackVars inp -> StackVars (RetOutStack' 'Tuple (x, y) ++ inp)
assignVars' (var1, var2) md :: StackVars inp
md = Var (ExprType' (Decide x) x)
-> StackVars (ExprType' (Decide y) y : inp)
-> StackVars
     (ExprType' (Decide x) x : ExprType' (Decide y) y : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (ExprType' (Decide x) x)
var1 (StackVars (ExprType' (Decide y) y : inp)
 -> StackVars (RetOutStack' 'Tuple (x, y) ++ inp))
-> StackVars (ExprType' (Decide y) y : inp)
-> StackVars (RetOutStack' 'Tuple (x, y) ++ inp)
forall a b. (a -> b) -> a -> b
$ Var (ExprType' (Decide y) y)
-> StackVars inp -> StackVars (ExprType' (Decide y) y : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (ExprType' (Decide y) y)
var2 StackVars inp
md
  prettyAssign' :: RetVars' 'Tuple (x, y) -> Text -> Text
prettyAssign' retVars :: RetVars' 'Tuple (x, y)
retVars stmt :: Text
stmt = (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y))
-> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y))
RetVars' 'Tuple (x, y)
retVars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " := " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stmt
  prettyRet' :: (x, y) -> Text
prettyRet' (x :: x
x, y :: y
y) = "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr (ExprType' (Decide x) x) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (x -> Expr (ExprType' (Decide x) x)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr x
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr (ExprType' (Decide y) y) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (y -> Expr (ExprType' (Decide y) y)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr y
y) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

instance (KnownValueExpr x
         , KnownValueExpr y
         , Buildable (RetVars' 'Tuple (x, y))
         ) => ScopeCodeGen' 'Tuple (x, y) where
  compileScopeReturn' :: (x, y) -> IndigoState xs (RetOutStack' 'Tuple (x, y) ++ xs)
compileScopeReturn' (e1 :: x
e1, e2 :: y
e2) = y -> IndigoState xs (ExprType' (Decide y) y : xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr y
e2 IndigoState xs (ExprType' (Decide y) y : xs)
-> IndigoState
     (ExprType' (Decide y) y : xs)
     (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
-> IndigoState
     xs (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
forall (inp :: [*]) (out :: [*]) (out1 :: [*]).
IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1
>> x
-> IndigoState
     (ExprType' (Decide y) y : xs)
     (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr x
e1
  -- TODO is L.dip . L.dip cheaper than L.dipN ?
  liftClear' :: (xs :-> inp)
-> (RetOutStack' 'Tuple (x, y) ++ xs)
   :-> (RetOutStack' 'Tuple (x, y) ++ inp)
liftClear' = ((ExprType' (Decide y) y : xs) :-> (ExprType' (Decide y) y : inp))
-> (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
   :-> (ExprType' (Decide x) x : ExprType' (Decide y) y : inp)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (((ExprType' (Decide y) y : xs) :-> (ExprType' (Decide y) y : inp))
 -> (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
    :-> (ExprType' (Decide x) x : ExprType' (Decide y) y : inp))
-> ((xs :-> inp)
    -> (ExprType' (Decide y) y : xs)
       :-> (ExprType' (Decide y) y : inp))
-> (xs :-> inp)
-> (ExprType' (Decide x) x : ExprType' (Decide y) y : xs)
   :-> (ExprType' (Decide x) x : ExprType' (Decide y) y : inp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (xs :-> inp)
-> (ExprType' (Decide y) y : xs) :-> (ExprType' (Decide y) y : inp)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
  genGcClear' :: (RetOutStack' 'Tuple (x, y) ++ inp) :-> inp
genGcClear' = (ExprType' (Decide x) x : ExprType' (Decide y) y : inp)
:-> (ExprType' (Decide y) y : inp)
forall a (s :: [*]). (a : s) :-> s
L.drop ((ExprType' (Decide x) x : ExprType' (Decide y) y : inp)
 :-> (ExprType' (Decide y) y : inp))
-> ((ExprType' (Decide y) y : inp) :-> inp)
-> (ExprType' (Decide x) x : ExprType' (Decide y) y : inp) :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (ExprType' (Decide y) y : inp) :-> inp
forall a (s :: [*]). (a : s) :-> s
L.drop

instance ( KnownValueExpr x
         , KnownValueExpr y
         , KnownValueExpr z
         , Buildable (RetVars' 'Tuple (x, y, z))
         ) => ReturnableValue' 'Tuple (x, y, z) where
  type RetOutStack' 'Tuple (x, y, z) = ExprType x ': ExprType y ': '[ExprType z]
  type RetVars' 'Tuple (x, y, z) = (Var (ExprType x), Var (ExprType y), Var (ExprType z))
  type RetExprs' 'Tuple (x, y, z) = (ExprType x, ExprType y, ExprType z)
  allocateVars' :: (forall x. m (Var x)) -> m (RetVars' 'Tuple (x, y, z))
allocateVars' allocator :: forall x. m (Var x)
allocator = (,,) (Var (ExprType' (Decide x) x)
 -> Var (ExprType' (Decide y) y)
 -> Var (ExprType' (Decide z) z)
 -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
     Var (ExprType' (Decide z) z)))
-> m (Var (ExprType' (Decide x) x))
-> m (Var (ExprType' (Decide y) y)
      -> Var (ExprType' (Decide z) z)
      -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
          Var (ExprType' (Decide z) z)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Var (ExprType' (Decide x) x))
forall x. m (Var x)
allocator m (Var (ExprType' (Decide y) y)
   -> Var (ExprType' (Decide z) z)
   -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
       Var (ExprType' (Decide z) z)))
-> m (Var (ExprType' (Decide y) y))
-> m (Var (ExprType' (Decide z) z)
      -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
          Var (ExprType' (Decide z) z)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Var (ExprType' (Decide y) y))
forall x. m (Var x)
allocator m (Var (ExprType' (Decide z) z)
   -> (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
       Var (ExprType' (Decide z) z)))
-> m (Var (ExprType' (Decide z) z))
-> m (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
      Var (ExprType' (Decide z) z))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Var (ExprType' (Decide z) z))
forall x. m (Var x)
allocator
  assignVars' :: RetVars' 'Tuple (x, y, z)
-> StackVars inp
-> StackVars (RetOutStack' 'Tuple (x, y, z) ++ inp)
assignVars' (var1, var2, var3) md :: StackVars inp
md =
    Var (ExprType' (Decide x) x)
-> StackVars
     (ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
-> StackVars
     (ExprType' (Decide x) x
        : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (ExprType' (Decide x) x)
var1 (StackVars (ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
 -> StackVars
      (ExprType' (Decide x) x
         : ExprType' (Decide y) y : ExprType' (Decide z) z : inp))
-> (StackVars (ExprType' (Decide z) z : inp)
    -> StackVars
         (ExprType' (Decide y) y : ExprType' (Decide z) z : inp))
-> StackVars (ExprType' (Decide z) z : inp)
-> StackVars
     (ExprType' (Decide x) x
        : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (ExprType' (Decide y) y)
-> StackVars (ExprType' (Decide z) z : inp)
-> StackVars
     (ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (ExprType' (Decide y) y)
var2 (StackVars (ExprType' (Decide z) z : inp)
 -> StackVars (RetOutStack' 'Tuple (x, y, z) ++ inp))
-> StackVars (ExprType' (Decide z) z : inp)
-> StackVars (RetOutStack' 'Tuple (x, y, z) ++ inp)
forall a b. (a -> b) -> a -> b
$ Var (ExprType' (Decide z) z)
-> StackVars inp -> StackVars (ExprType' (Decide z) z : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (ExprType' (Decide z) z)
var3 StackVars inp
md
  prettyAssign' :: RetVars' 'Tuple (x, y, z) -> Text -> Text
prettyAssign' retVars :: RetVars' 'Tuple (x, y, z)
retVars stmt :: Text
stmt = (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
 Var (ExprType' (Decide z) z))
-> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Var (ExprType' (Decide x) x), Var (ExprType' (Decide y) y),
 Var (ExprType' (Decide z) z))
RetVars' 'Tuple (x, y, z)
retVars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " := " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stmt
  prettyRet' :: (x, y, z) -> Text
prettyRet' (x :: x
x, y :: y
y, z :: z
z) = "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr (ExprType' (Decide x) x) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (x -> Expr (ExprType' (Decide x) x)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr x
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr (ExprType' (Decide y) y) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (y -> Expr (ExprType' (Decide y) y)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr y
y) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr (ExprType' (Decide z) z) -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (z -> Expr (ExprType' (Decide z) z)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr z
z) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

instance (KnownValueExpr x
         , KnownValueExpr y
         , KnownValueExpr z
         , Buildable (RetVars' 'Tuple (x, y, z))
         ) => ScopeCodeGen' 'Tuple (x, y, z) where
  compileScopeReturn' :: (x, y, z) -> IndigoState xs (RetOutStack' 'Tuple (x, y, z) ++ xs)
compileScopeReturn' (e1 :: x
e1, e2 :: y
e2, e3 :: z
e3) = z -> IndigoState xs (ExprType' (Decide z) z : xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr z
e3 IndigoState xs (ExprType' (Decide z) z : xs)
-> IndigoState
     (ExprType' (Decide z) z : xs)
     (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
-> IndigoState
     xs (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
forall (inp :: [*]) (out :: [*]) (out1 :: [*]).
IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1
>> y
-> IndigoState
     (ExprType' (Decide z) z : xs)
     (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr y
e2 IndigoState
  xs (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
-> IndigoState
     (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
     (ExprType' (Decide x) x
        : ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
-> IndigoState
     xs
     (ExprType' (Decide x) x
        : ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
forall (inp :: [*]) (out :: [*]) (out1 :: [*]).
IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1
>> x
-> IndigoState
     (ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
     (ExprType' (Decide x) x
        : ExprType' (Decide y) y : ExprType' (Decide z) z : xs)
forall a (inp :: [*]).
ToExpr a =>
a -> IndigoState inp (ExprType a : inp)
compileToExpr x
e1
  liftClear' :: (xs :-> inp)
-> (RetOutStack' 'Tuple (x, y, z) ++ xs)
   :-> (RetOutStack' 'Tuple (x, y, z) ++ inp)
liftClear' = forall (inp :: [*]) (out :: [*]) (s :: [*]) (s' :: [*]).
ConstraintDIPNLorentz (ToPeano 3) inp out s s' =>
(s :-> s') -> inp :-> out
forall (n :: Nat) (inp :: [*]) (out :: [*]) (s :: [*]) (s' :: [*]).
ConstraintDIPNLorentz (ToPeano n) inp out s s' =>
(s :-> s') -> inp :-> out
L.dipN @3
  genGcClear' :: (RetOutStack' 'Tuple (x, y, z) ++ inp) :-> inp
genGcClear' = (ExprType' (Decide x) x
   : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
:-> (ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
forall a (s :: [*]). (a : s) :-> s
L.drop ((ExprType' (Decide x) x
    : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
 :-> (ExprType' (Decide y) y : ExprType' (Decide z) z : inp))
-> ((ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
    :-> (ExprType' (Decide z) z : inp))
-> (ExprType' (Decide x) x
      : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
   :-> (ExprType' (Decide z) z : inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
:-> (ExprType' (Decide z) z : inp)
forall a (s :: [*]). (a : s) :-> s
L.drop ((ExprType' (Decide x) x
    : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
 :-> (ExprType' (Decide z) z : inp))
-> ((ExprType' (Decide z) z : inp) :-> inp)
-> (ExprType' (Decide x) x
      : ExprType' (Decide y) y : ExprType' (Decide z) z : inp)
   :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (ExprType' (Decide z) z : inp) :-> inp
forall a (s :: [*]). (a : s) :-> s
L.drop

-- | Utility function to compile from an 'IsExpr'
compileToExpr :: ToExpr a => a -> IndigoState inp ((ExprType a) : inp)
compileToExpr :: a -> IndigoState inp (ExprType a : inp)
compileToExpr = Expr (ExprType a) -> IndigoState inp (ExprType a : inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr (Expr (ExprType a) -> IndigoState inp (ExprType a : inp))
-> (a -> Expr (ExprType a))
-> a
-> IndigoState inp (ExprType a : inp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Expr (ExprType a)
forall a. ToExpr a => a -> Expr (ExprType a)
toExpr