Simple.hs

-- 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
code -$? inp = interpretLorentzLambda dummyContractEnv (unzipInstr # code) 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
code -$ inp = either (error . pretty) id $ code -$? inp

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

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

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

----------------------------------------------------------------------------
-- 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]
code <-$> inps = map (code -$) inps