-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE InstanceSigs #-}

{- |
This module contains the core of Indigo language:
'IndigoState', a datatype that represents its state.
It also includes some convenient functions to work with it,
to provide rebindable syntax.

'IndigoState' implements the functionality of a symbolic interpreter.
During its execution Lorentz code is being generated.

Functionally, it's the same as having Lorentz instruction that can access and
modify a 'StackVars', referring to values on the stack with a 'RefId'.
-}

module Indigo.Common.State
  ( -- * Indigo State
    IndigoState (..)
  , usingIndigoState
  , (>>)
  , (<$>)
  , iput
  , nopState
  , assignTopVar
  , withObject
  , withObjectState
  , withStackVars

  , DecomposedObjects
  , GenCodeHooks (..)
  , emptyGenCodeHooks
  , MetaData (..)
  , stmtHook
  , stmtHookState
  , auxiliaryHook
  , auxiliaryHookState
  , exprHook
  , exprHookState
  , replStkMd
  , alterStkMd
  , pushRefMd
  , pushNoRefMd
  , popNoRefMd

  , GenCode (..)
  , cleanGenCode

  , (##)
  ) where

import Data.Map qualified as M
import Data.Typeable (eqT, (:~:)(..))
import Fmt (pretty)

import Indigo.Backend.Prelude
import Indigo.Common.Object
import Indigo.Common.Var
import Indigo.Lorentz
import Lorentz.Instr qualified as L
import Morley.Michelson.Typed qualified as M
import Morley.Util.Peano

----------------------------------------------------------------------------
-- Indigo State
----------------------------------------------------------------------------

-- | IndigoState data type.
--
-- It takes as input a 'StackVars' (for the initial state) and returns a
-- 'GenCode' (for the resulting state and the generated Lorentz code).
--
-- IndigoState has to be used to write backend typed Lorentz code
-- from the corresponding frontend constructions.
--
-- It has no return type, IndigoState instruction may take one or more
-- "return variables", that they assign to values produced during their execution.
newtype IndigoState inp out = IndigoState {
    forall (inp :: [*]) (out :: [*]).
IndigoState inp out -> MetaData inp -> GenCode inp out
runIndigoState :: MetaData inp -> GenCode inp out
  }

-- | Inverse of 'runIndigoState' for utility.
usingIndigoState :: MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState :: forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md IndigoState inp out
act = IndigoState inp out -> MetaData inp -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
IndigoState inp out -> MetaData inp -> GenCode inp out
runIndigoState IndigoState inp out
act MetaData inp
md

-- | Then for rebindable syntax.
(>>) :: IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1
>> :: forall (inp :: [*]) (out :: [*]) (out1 :: [*]).
IndigoState inp out -> IndigoState out out1 -> IndigoState inp out1
(>>) IndigoState inp out
a IndigoState out out1
b = (MetaData inp -> GenCode inp out1) -> IndigoState inp out1
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out1) -> IndigoState inp out1)
-> (MetaData inp -> GenCode inp out1) -> IndigoState inp out1
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md ->
  let GenCode StackVars out
st1 inp :-> out
cd1 out :-> inp
cl1 = IndigoState inp out -> MetaData inp -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
IndigoState inp out -> MetaData inp -> GenCode inp out
runIndigoState IndigoState inp out
a MetaData inp
md in
  let GenCode StackVars out1
st2 out :-> out1
cd2 out1 :-> out
cl2 = IndigoState out out1 -> MetaData out -> GenCode out out1
forall (inp :: [*]) (out :: [*]).
IndigoState inp out -> MetaData inp -> GenCode inp out
runIndigoState IndigoState out out1
b (MetaData inp -> StackVars out -> MetaData out
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md StackVars out
st1) in
  StackVars out1
-> (inp :-> out1) -> (out1 :-> inp) -> GenCode inp out1
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars out1
st2 (inp :-> out
cd1 (inp :-> out) -> (out :-> out1) -> inp :-> out1
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
## out :-> out1
cd2) (out1 :-> out
cl2 (out1 :-> out) -> (out :-> inp) -> out1 :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
## out :-> inp
cl1)

-- | Put new 'GenCode'.
iput :: GenCode inp out -> IndigoState inp out
iput :: forall (inp :: [*]) (out :: [*]).
GenCode inp out -> IndigoState inp out
iput GenCode inp out
gc = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
_ -> GenCode inp out
gc

-- | The simplest 'IndigoState', it does not modify the stack, nor the produced
-- code.
nopState :: IndigoState inp inp
nopState :: forall (inp :: [*]). IndigoState inp inp
nopState = (MetaData inp -> GenCode inp inp) -> IndigoState inp inp
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp inp) -> IndigoState inp inp)
-> (MetaData inp -> GenCode inp inp) -> IndigoState inp inp
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md -> StackVars inp -> (inp :-> inp) -> (inp :-> inp) -> GenCode inp inp
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode (MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md) inp :-> inp
forall (s :: [*]). s :-> s
L.nop inp :-> inp
forall (s :: [*]). s :-> s
L.nop

-- | Assigns a variable to reference the element on top of the stack.
assignTopVar :: KnownValue x => Var x -> IndigoState (x : inp) (x : inp)
assignTopVar :: forall x (inp :: [*]).
KnownValue x =>
Var x -> IndigoState (x : inp) (x : inp)
assignTopVar Var x
var = (MetaData (x : inp) -> GenCode (x : inp) (x : inp))
-> IndigoState (x : inp) (x : inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData (x : inp) -> GenCode (x : inp) (x : inp))
 -> IndigoState (x : inp) (x : inp))
-> (MetaData (x : inp) -> GenCode (x : inp) (x : inp))
-> IndigoState (x : inp) (x : inp)
forall a b. (a -> b) -> a -> b
$ \MetaData (x : inp)
md ->
  StackVars (x : inp)
-> ((x : inp) :-> (x : inp))
-> ((x : inp) :-> (x : inp))
-> GenCode (x : inp) (x : inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode (Var x -> StackVars (x : inp) -> Sing 'Z -> StackVars (x : inp)
forall a (n :: Nat) (inp :: [*]).
(KnownValue a, a ~ At n inp, RequireLongerThan inp n) =>
Var a -> StackVars inp -> Sing n -> StackVars inp
assignVarAt Var x
var (MetaData (x : inp) -> StackVars (x : inp)
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData (x : inp)
md) Sing 'Z
SingNat 'Z
SZ) (x : inp) :-> (x : inp)
forall (s :: [*]). s :-> s
L.nop (x : inp) :-> (x : inp)
forall (s :: [*]). s :-> s
L.nop

withObject
  :: forall a r .  KnownValue a
  => DecomposedObjects
  -> Var a
  -> (Object a -> r)
  -> r
withObject :: forall a r.
KnownValue a =>
DecomposedObjects -> Var a -> (Object a -> r) -> r
withObject DecomposedObjects
objs (Var RefId
refId) Object a -> r
f = case RefId -> DecomposedObjects -> Maybe SomeObject
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RefId
refId DecomposedObjects
objs of
  Maybe SomeObject
Nothing -> Object a -> r
f (RefId -> Object a
forall a (f :: Symbol -> *).
KnownValue a =>
RefId -> IndigoObjectF f a
Cell RefId
refId)
  Just SomeObject
so -> case SomeObject
so of
    SomeObject (Object a
obj :: Object a1) -> case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @a1 of
      Just a :~: a
Refl -> Object a -> r
f Object a
Object a
obj
      Maybe (a :~: a)
Nothing ->
        Text -> r
forall a. HasCallStack => Text -> a
error (Text -> r) -> Text -> r
forall a b. (a -> b) -> a -> b
$ Text
"unexpectedly SomeObject with by reference #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RefId -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty RefId
refId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has different type"

withObjectState
  :: forall a inp out . KnownValue a
  => Var a
  -> (Object a -> IndigoState inp out)
  -> IndigoState inp out
withObjectState :: forall a (inp :: [*]) (out :: [*]).
KnownValue a =>
Var a -> (Object a -> IndigoState inp out) -> IndigoState inp out
withObjectState Var a
v Object a -> IndigoState inp out
f = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md -> MetaData inp -> IndigoState inp out -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (DecomposedObjects
-> Var a
-> (Object a -> IndigoState inp out)
-> IndigoState inp out
forall a r.
KnownValue a =>
DecomposedObjects -> Var a -> (Object a -> r) -> r
withObject (MetaData inp -> DecomposedObjects
forall (inp :: [*]). MetaData inp -> DecomposedObjects
mdObjects MetaData inp
md) Var a
v Object a -> IndigoState inp out
f)

-- | Utility function to create 'IndigoState' that need access to the current 'StackVars'.
withStackVars :: (StackVars inp -> IndigoState inp out) -> IndigoState inp out
withStackVars :: forall (inp :: [*]) (out :: [*]).
(StackVars inp -> IndigoState inp out) -> IndigoState inp out
withStackVars StackVars inp -> IndigoState inp out
fIs = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md -> MetaData inp -> IndigoState inp out -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (StackVars inp -> IndigoState inp out
fIs (StackVars inp -> IndigoState inp out)
-> StackVars inp -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ MetaData inp -> StackVars inp
forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack MetaData inp
md)

----------------------------------------------------------------------------
-- MetaData primitives
----------------------------------------------------------------------------

type DecomposedObjects = Map RefId SomeObject

data MetaData inp = MetaData
  { forall (inp :: [*]). MetaData inp -> StackVars inp
mdStack   :: StackVars inp
  , forall (inp :: [*]). MetaData inp -> DecomposedObjects
mdObjects :: DecomposedObjects
  , forall (inp :: [*]). MetaData inp -> GenCodeHooks
mdHooks   :: GenCodeHooks
  }

data GenCodeHooks = GenCodeHooks
  { GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchStmtHook      :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)
  , GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchAuxiliaryHook :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)
  , GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchExprHook      :: forall inp out . Text -> (inp :-> out) -> (inp :-> out)
  -- pva701: dunno whether this level of verbosity is needed
  --, csSubExpr    :: forall a inp out . Expr a -> (inp :-> out) -> (inp :-> out)
  }

instance Semigroup GenCodeHooks where
  GenCodeHooks forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
a forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
b forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
c <> :: GenCodeHooks -> GenCodeHooks -> GenCodeHooks
<> GenCodeHooks forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
a1 forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
b1 forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
c1 = GenCodeHooks :: (forall (inp :: [*]) (out :: [*]).
 Text -> (inp :-> out) -> inp :-> out)
-> (forall (inp :: [*]) (out :: [*]).
    Text -> (inp :-> out) -> inp :-> out)
-> (forall (inp :: [*]) (out :: [*]).
    Text -> (inp :-> out) -> inp :-> out)
-> GenCodeHooks
GenCodeHooks
    { gchStmtHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchStmtHook = \Text
t inp :-> out
cd -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
a1 Text
t (Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
a Text
t inp :-> out
cd)
    , gchAuxiliaryHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchAuxiliaryHook = \Text
t inp :-> out
cd -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
b1 Text
t (Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
b Text
t inp :-> out
cd)
    , gchExprHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchExprHook = \Text
t inp :-> out
cd -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
c1 Text
t (Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
c Text
t inp :-> out
cd)
    }

instance Monoid GenCodeHooks where
  mempty :: GenCodeHooks
mempty = GenCodeHooks
emptyGenCodeHooks

emptyGenCodeHooks :: GenCodeHooks
emptyGenCodeHooks :: GenCodeHooks
emptyGenCodeHooks = (forall (inp :: [*]) (out :: [*]).
 Text -> (inp :-> out) -> inp :-> out)
-> (forall (inp :: [*]) (out :: [*]).
    Text -> (inp :-> out) -> inp :-> out)
-> (forall (inp :: [*]) (out :: [*]).
    Text -> (inp :-> out) -> inp :-> out)
-> GenCodeHooks
GenCodeHooks (((inp :-> out) -> inp :-> out)
-> Text -> (inp :-> out) -> inp :-> out
forall a b. a -> b -> a
const (inp :-> out) -> inp :-> out
forall a. a -> a
id) (((inp :-> out) -> inp :-> out)
-> Text -> (inp :-> out) -> inp :-> out
forall a b. a -> b -> a
const (inp :-> out) -> inp :-> out
forall a. a -> a
id) (((inp :-> out) -> inp :-> out)
-> Text -> (inp :-> out) -> inp :-> out
forall a b. a -> b -> a
const (inp :-> out) -> inp :-> out
forall a. a -> a
id)

stmtHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)
stmtHook :: forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
stmtHook MetaData{DecomposedObjects
StackVars any
GenCodeHooks
mdHooks :: GenCodeHooks
mdObjects :: DecomposedObjects
mdStack :: StackVars any
mdHooks :: forall (inp :: [*]). MetaData inp -> GenCodeHooks
mdObjects :: forall (inp :: [*]). MetaData inp -> DecomposedObjects
mdStack :: forall (inp :: [*]). MetaData inp -> StackVars inp
..} Text
tx inp :-> out
cd = (GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchStmtHook GenCodeHooks
mdHooks) Text
tx inp :-> out
cd

stmtHookState :: Text -> IndigoState inp out -> IndigoState inp out
stmtHookState :: forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
stmtHookState Text
tx IndigoState inp out
cd = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md ->
  let GenCode StackVars out
st inp :-> out
c out :-> inp
cl = MetaData inp -> IndigoState inp out -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md IndigoState inp out
cd in
  StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars out
st (MetaData inp -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
stmtHook MetaData inp
md Text
tx inp :-> out
c) out :-> inp
cl

auxiliaryHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)
auxiliaryHook :: forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData{DecomposedObjects
StackVars any
GenCodeHooks
mdHooks :: GenCodeHooks
mdObjects :: DecomposedObjects
mdStack :: StackVars any
mdHooks :: forall (inp :: [*]). MetaData inp -> GenCodeHooks
mdObjects :: forall (inp :: [*]). MetaData inp -> DecomposedObjects
mdStack :: forall (inp :: [*]). MetaData inp -> StackVars inp
..} Text
tx inp :-> out
cd = (GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchAuxiliaryHook GenCodeHooks
mdHooks) Text
tx inp :-> out
cd

auxiliaryHookState :: Text -> IndigoState inp out -> IndigoState inp out
auxiliaryHookState :: forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
auxiliaryHookState Text
tx IndigoState inp out
cd = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md ->
  let GenCode StackVars out
st inp :-> out
c out :-> inp
cl = MetaData inp -> IndigoState inp out -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md IndigoState inp out
cd in
  StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars out
st (MetaData inp -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md Text
tx inp :-> out
c) out :-> inp
cl

exprHook :: forall inp out any . MetaData any -> Text -> (inp :-> out) -> (inp :-> out)
exprHook :: forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
exprHook MetaData{DecomposedObjects
StackVars any
GenCodeHooks
mdHooks :: GenCodeHooks
mdObjects :: DecomposedObjects
mdStack :: StackVars any
mdHooks :: forall (inp :: [*]). MetaData inp -> GenCodeHooks
mdObjects :: forall (inp :: [*]). MetaData inp -> DecomposedObjects
mdStack :: forall (inp :: [*]). MetaData inp -> StackVars inp
..} Text
exTx inp :-> out
cd = (GenCodeHooks
-> forall (inp :: [*]) (out :: [*]).
   Text -> (inp :-> out) -> inp :-> out
gchExprHook GenCodeHooks
mdHooks) Text
exTx inp :-> out
cd

exprHookState :: Text -> IndigoState inp out -> IndigoState inp out
exprHookState :: forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
exprHookState Text
tx IndigoState inp out
cd = (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp out) -> IndigoState inp out)
-> (MetaData inp -> GenCode inp out) -> IndigoState inp out
forall a b. (a -> b) -> a -> b
$ \MetaData inp
md ->
  let GenCode StackVars out
st inp :-> out
c out :-> inp
cl = MetaData inp -> IndigoState inp out -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md IndigoState inp out
cd in
  StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars out
st (MetaData inp -> Text -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
exprHook MetaData inp
md Text
tx inp :-> out
c) out :-> inp
cl


replStkMd :: MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd :: forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md = MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd MetaData inp
md ((StackVars inp -> StackVars inp1) -> MetaData inp1)
-> (StackVars inp1 -> StackVars inp -> StackVars inp1)
-> StackVars inp1
-> MetaData inp1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackVars inp1 -> StackVars inp -> StackVars inp1
forall a b. a -> b -> a
const

alterStkMd :: MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd :: forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd (MetaData StackVars inp
stk DecomposedObjects
objs GenCodeHooks
cm) StackVars inp -> StackVars inp1
f = StackVars inp1
-> DecomposedObjects -> GenCodeHooks -> MetaData inp1
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> GenCodeHooks -> MetaData inp
MetaData (StackVars inp -> StackVars inp1
f StackVars inp
stk) DecomposedObjects
objs GenCodeHooks
cm

-- | 'pushRef' version for 'MetaData'
pushRefMd :: KnownValue a => Var a -> MetaData inp -> MetaData (a : inp)
pushRefMd :: forall a (inp :: [*]).
KnownValue a =>
Var a -> MetaData inp -> MetaData (a : inp)
pushRefMd Var a
var MetaData inp
md = MetaData inp
-> (StackVars inp -> StackVars (a : inp)) -> MetaData (a : inp)
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd MetaData inp
md (Var a -> StackVars inp -> StackVars (a : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var a
var)

-- | 'pushNoRef' version for 'MetaData'
pushNoRefMd :: KnownValue a => MetaData inp -> MetaData (a : inp)
pushNoRefMd :: forall a (inp :: [*]).
KnownValue a =>
MetaData inp -> MetaData (a : inp)
pushNoRefMd MetaData inp
md = MetaData inp
-> (StackVars inp -> StackVars (a : inp)) -> MetaData (a : inp)
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd MetaData inp
md StackVars inp -> StackVars (a : inp)
forall a (inp :: [*]).
KnownValue a =>
StackVars inp -> StackVars (a : inp)
pushNoRef

-- | 'popNoRef' version for 'MetaData'
popNoRefMd :: MetaData (a : inp) -> MetaData inp
popNoRefMd :: forall a (inp :: [*]). MetaData (a : inp) -> MetaData inp
popNoRefMd MetaData (a : inp)
md = MetaData (a : inp)
-> (StackVars (a : inp) -> StackVars inp) -> MetaData inp
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> (StackVars inp -> StackVars inp1) -> MetaData inp1
alterStkMd MetaData (a : inp)
md StackVars (a : inp) -> StackVars inp
forall a (inp :: [*]). StackVars (a : inp) -> StackVars inp
popNoRef

----------------------------------------------------------------------------
-- Code generation primitives
----------------------------------------------------------------------------

-- | Resulting state of IndigoM.
data GenCode inp out = GenCode
  { forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
gcStack :: ~(StackVars out)
  -- ^ Stack of the symbolic interpreter.
  , forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode  :: inp :-> out
  -- ^ Generated Lorentz code.
  , forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcClear :: out :-> inp
  -- ^ Clearing Lorentz code.
  }

-- | Produces the generated Lorentz code that cleans after itself, leaving the
-- same stack as the input one
cleanGenCode :: GenCode inp out -> inp :-> inp
cleanGenCode :: forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> inp
cleanGenCode GenCode {inp :-> out
out :-> inp
StackVars out
gcClear :: out :-> inp
gcCode :: inp :-> out
gcStack :: StackVars out
gcClear :: forall (inp :: [*]) (out :: [*]). GenCode inp out -> out :-> inp
gcCode :: forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcStack :: forall (inp :: [*]) (out :: [*]). GenCode inp out -> StackVars out
..} = inp :-> out
gcCode (inp :-> out) -> (out :-> inp) -> inp :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
## out :-> inp
gcClear

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Version of '#' which performs some optimizations immediately.
--
-- In particular, this avoids glueing @Nop@s.
(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)
a :-> b
l ## :: forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
## b :-> c
r =
  -- We are very verbose about cases to avoid
  -- significant compilation time increase
  case a :-> b
l of
    I Instr (ToTs a) (ToTs b)
M.Nop -> case b :-> c
r of
      I Instr (ToTs b) (ToTs c)
x -> Instr (ToTs a) (ToTs c) -> a :-> c
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I Instr (ToTs a) (ToTs c)
Instr (ToTs b) (ToTs c)
x
      b :-> c
_   -> a :-> b
l (a :-> b) -> (b :-> c) -> a :-> c
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# b :-> c
r
    I Instr (ToTs a) (ToTs b)
x -> case b :-> c
r of
      I Instr (ToTs b) (ToTs c)
M.Nop -> Instr (ToTs a) (ToTs c) -> a :-> c
forall (inp :: [*]) (out :: [*]).
Instr (ToTs inp) (ToTs out) -> inp :-> out
I Instr (ToTs a) (ToTs b)
Instr (ToTs a) (ToTs c)
x
      b :-> c
_       -> a :-> b
l (a :-> b) -> (b :-> c) -> a :-> c
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# b :-> c
r
    a :-> b
_ -> a :-> b
l (a :-> b) -> (b :-> c) -> a :-> c
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# b :-> c
r