Print.hs

{-# LANGUAGE DeriveAnyClass #-}

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

import Prelude hiding (drop, swap)
import Test.HUnit (Assertion, assertEqual, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Lorentz hiding (contract, unpack)
import qualified Lorentz as L
import Michelson.Printer.Util (buildRenderDoc)
import Michelson.Typed hiding (ContractCode)
import Michelson.Untyped (para)

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

instance ParameterHasEntryPoints MyEntryPoints1 where
  type ParameterEntryPointsDerivation MyEntryPoints1 = EpdPlain

contract :: ContractCode MyEntryPoints1 ()
contract = drop # unit # nil # pair

test_Print_parameter_annotations :: [TestTree]
test_Print_parameter_annotations =
  [ testCase "Simple parameter" $
      let typedContract = compileLorentzContract contract
          untypedContract = convertFullContract typedContract
      in buildRenderDoc (para 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" :! Bool)
  | TestCon2 ()
  deriving stock Generic
  deriving anyclass IsoValue

instance ParameterHasEntryPoints TestParam where
  type ParameterEntryPointsDerivation TestParam = EpdRecursive

unit_Erase_annotations :: Assertion
unit_Erase_annotations =
  let
    myContract :: ContractCode TestParam ()
    myContract = cdr # nil # L.pair
    expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };"
  in assertEqual
      "Printed Lorentz contract is supposed to have an instruction which erases\
      \all parameter annotations, but it does not match the expected output"
      expected (L.printLorentzContract True myContract)