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

-- | Running Lorentz code easily.
--
-- For testing and demonstration purposes.
module Lorentz.Run.Simple
  ( (-$?)
  , (-$)
  , (&?-)
  , (&-)
  , (<-$>)
  ) where

import Fmt (pretty)

import Lorentz.Base
import Lorentz.Run
import Lorentz.Value
import Lorentz.Zip
import Michelson.Interpret
import Michelson.Runtime.Dummy (dummyContractEnv)

{- Note about priority:

We want priority of our operators to be higher than of operators from HUnit
(which is 1), but less than priority of the most our other operators like '#'.
-}

----------------------------------------------------------------------------
-- Common case
----------------------------------------------------------------------------

-- | Run a lambda with given input.
--
-- Note that this always returns one value, but can accept multiple
-- input values (in such case they are grouped into nested pairs).
--
-- For testing and demonstration purposes.
infixr 2 -$?
(-$?) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out)
      => (inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
inps :-> '[out]
code -$? :: (inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
-$? ZippedStack inps
inp = ContractEnv
-> Lambda (ZippedStack inps) out
-> ZippedStack inps
-> Either MichelsonFailed out
forall inp out.
(IsoValue inp, IsoValue out) =>
ContractEnv -> Lambda inp out -> inp -> Either MichelsonFailed out
interpretLorentzLambda ContractEnv
dummyContractEnv ('[ZippedStack inps] :-> inps
forall (s :: [*]). ZipInstr s => '[ZippedStack s] :-> s
unzipInstr ('[ZippedStack inps] :-> inps)
-> (inps :-> '[out]) -> Lambda (ZippedStack inps) out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# inps :-> '[out]
code) ZippedStack inps
inp

-- | Like @'-$?'@, assumes that no failure is possible.
--
-- For testing and demonstration purposes.
--
-- >>> import Lorentz.Instr
--
-- >>> nop -$ 5
-- 5
-- >>> sub -$ (3, 2)
-- 1
-- >>> push 9 -$ ()
-- 9
-- >>> add # add -$ ((1, 2), 3)
-- 6
infixr 2 -$
(-$) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack)
     => inps :-> '[out] -> ZippedStack inps -> out
inps :-> '[out]
code -$ :: (inps :-> '[out]) -> ZippedStack inps -> out
-$ ZippedStack inps
inp = (MichelsonFailed -> out)
-> (out -> out) -> Either MichelsonFailed out -> out
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> out
forall a. HasCallStack => Text -> a
error (Text -> out)
-> (MichelsonFailed -> Text) -> MichelsonFailed -> out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MichelsonFailed -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) out -> out
forall a. a -> a
id (Either MichelsonFailed out -> out)
-> Either MichelsonFailed out -> out
forall a b. (a -> b) -> a -> b
$ inps :-> '[out]
code (inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
forall (inps :: [*]) out.
(ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out) =>
(inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
-$? ZippedStack inps
inp

----------------------------------------------------------------------------
-- Flipped versions
----------------------------------------------------------------------------

-- | Version of (-$?) with arguments flipped.
infixl 2 &?-
(&?-) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out)
      => ZippedStack inps -> (inps :-> '[out]) -> Either MichelsonFailed out
&?- :: ZippedStack inps -> (inps :-> '[out]) -> Either MichelsonFailed out
(&?-) = ((inps :-> '[out])
 -> ZippedStack inps -> Either MichelsonFailed out)
-> ZippedStack inps
-> (inps :-> '[out])
-> Either MichelsonFailed out
forall a b c. (a -> b -> c) -> b -> a -> c
flip (inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
forall (inps :: [*]) out.
(ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out) =>
(inps :-> '[out]) -> ZippedStack inps -> Either MichelsonFailed out
(-$?)

-- | Version of (-$) with arguments flipped.
infixl 2 &-
(&-) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack)
     => ZippedStack inps -> (inps :-> '[out]) -> out
&- :: ZippedStack inps -> (inps :-> '[out]) -> out
(&-) = ((inps :-> '[out]) -> ZippedStack inps -> out)
-> ZippedStack inps -> (inps :-> '[out]) -> out
forall a b c. (a -> b -> c) -> b -> a -> c
flip (inps :-> '[out]) -> ZippedStack inps -> out
forall (inps :: [*]) out.
(ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out,
 HasCallStack) =>
(inps :-> '[out]) -> ZippedStack inps -> out
(-$)

----------------------------------------------------------------------------
-- Experimental versions
----------------------------------------------------------------------------

-- | Version of (-$) applicable to a series of values.
infixl 2 <-$>
(<-$>) :: (ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out, HasCallStack)
       => (inps :-> '[out]) -> [ZippedStack inps] -> [out]
inps :-> '[out]
code <-$> :: (inps :-> '[out]) -> [ZippedStack inps] -> [out]
<-$> [ZippedStack inps]
inps = (ZippedStack inps -> out) -> [ZippedStack inps] -> [out]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (inps :-> '[out]
code (inps :-> '[out]) -> ZippedStack inps -> out
forall (inps :: [*]) out.
(ZipInstr inps, IsoValue (ZippedStack inps), IsoValue out,
 HasCallStack) =>
(inps :-> '[out]) -> ZippedStack inps -> out
-$) [ZippedStack inps]
inps