Print.hs

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

-- | Tests on Lorentz contracts pretty-printing.
module Test.Lorentz.Print
  ( test_Print_parameter_annotations
  , test_Print_lambda
  , unit_Erase_annotations
  , unit_Does_not_erase_annotations
  ) where

import Lorentz hiding (contract, unpack)
import Lorentz qualified as L
import Prelude hiding (drop, swap)

import Test.HUnit (Assertion, assertEqual, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Printer.Util (buildRenderDoc)
import Morley.Michelson.Typed hiding (Contract, ContractCode, defaultContract)
import Morley.Michelson.Untyped (contractParameter)

data MyEntrypoints1
  = Do1 Integer
  | Do2 (Integer, Integer)
  | Do3
  deriving stock Generic
  deriving anyclass IsoValue

instance ParameterHasEntrypoints MyEntrypoints1 where
  type ParameterEntrypointsDerivation MyEntrypoints1 = EpdPlain

contract :: Contract MyEntrypoints1 () ()
contract = defaultContract $
  drop # unit # nil # pair

test_Print_parameter_annotations :: [TestTree]
test_Print_parameter_annotations =
  [ testCase "Simple parameter" $
      let typedContract = toMichelsonContract contract
          untypedContract = convertContract typedContract
      in buildRenderDoc (contractParameter untypedContract)
         @?=
         "or (int %do1) (or (pair %do2 int int) (unit %do3))"
  ]

test_Print_lambda :: [TestTree]
test_Print_lambda =
  [ testCase "Prints correct lambda instruction" $
      let
        code :: '[Integer] :-> '[('[Integer] :-> '[()])]
        code = drop # lambda (drop # unit)
     in printLorentzValue True code
        @?=
        "{ DROP;LAMBDA  int  unit  { DROP;UNIT } }"
  ]

data TestParam
  = TestCon1 ("a" :! Natural, "b" :! Natural)
  | TestCon2 Bool
  deriving stock Generic
  deriving anyclass IsoValue

instance ParameterHasEntrypoints TestParam where
  type ParameterEntrypointsDerivation TestParam = EpdRecursive

unit_Erase_annotations :: Assertion
unit_Erase_annotations =
  let
    myContract :: Contract TestParam Bool ()
    myContract = defaultContract $
        car
      # entryCase @TestParam (Proxy @PlainEntrypointsKind)
        ( #cTestCon1 /->
              unpair
            # dip (fromNamed #b)
            # fromNamed #a
            # eq
        , #cTestCon2 /-> nop
        )
      # nil
      # L.pair

    expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\
      \code { CAST (pair (or (pair nat nat) bool) bool);CAR;IF_LEFT { UNPAIR;COMPARE;EQ }\
      \        {  };NIL operation;PAIR };"
  in assertEqual
      "Printed Lorentz contract is supposed to have an instruction which erases\
      \all parameter annotations, if the contract doesn't typecheck,\
      \ but it does not match the expected output"
      expected (L.printLorentzContract True myContract)

unit_Does_not_erase_annotations :: Assertion
unit_Does_not_erase_annotations =
  let
    myContract :: Contract TestParam Bool ()
    myContract = defaultContract $
        car
      # entryCase @TestParam (Proxy @PlainEntrypointsKind)
        ( #cTestCon1 /->
              unpair
            # dip (fromNamed #b)
            # fromNamed #a
            # dropN @2
            # push False
        , #cTestCon2 /-> nop
        )
      # nil
      # L.pair

    expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\
      \code { CAR;IF_LEFT { UNPAIR;DROP 2;PUSH bool False }\
      \        {  };NIL operation;PAIR };"
  in assertEqual
      "Printed Lorentz contract is supposed to NOT have an instruction which erases\
      \all parameter annotations, if the contract DOES typecheck,\
      \ but it does not match the expected output"
      expected (L.printLorentzContract True myContract)