Macro.hs

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

-- | Tests for Lorentz macros.
--
-- They test logic of macros and type-level logic.  Also they serve as
-- examples of using complex macros (e. g. parameterized with
-- type-level numbers)

module Test.Lorentz.Macro
  ( unit_duupX
  , unit_replaceN
  , unit_updateN
  , test_execute
  , test_applicate
  ) where

import Lorentz
import Prelude hiding (drop, swap)

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


unit_duupX :: Assertion
unit_duupX = do
  duupX @1 @?= duupX1
  duupX @2 @?= duupX2
  duupX @3 @?= duupX3
  where
    duupX1 :: [Bool, Integer, (), Bool] :-> [Bool, Bool, Integer, (), Bool]
    duupX1 = dupN @1

    duupX2 :: [Bool, Integer, (), Bool] :-> [Integer, Bool, Integer, (), Bool]
    duupX2 = dupN @2

    duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool]
    duupX3 = dupN @3

unit_replaceN :: Assertion
unit_replaceN = do
  replaceN @1 @?= swap # drop
  replaceN @2 @?= replaceN2
  replaceN @3 @?= replaceN3
  where
    replaceN2 :: [(), Integer, (), Bool] :-> [Integer, (), Bool]
    replaceN2 = dipN @2 drop # dug @1

    replaceN3 :: [Bool, Integer, (), Bool] :-> [Integer, (), Bool]
    replaceN3 = dipN @3 drop # dug @2

unit_updateN :: Assertion
unit_updateN = do
  updateN @1 cons @?= updateN1
  updateN @2 cons @?= updateN2
  updateN @3 cons @?= updateN3
  where
    updateN1 :: [Bool, [Bool], Integer, ()] :-> [[Bool], Integer, ()]
    updateN1 = cons

    updateN2 :: [Bool, Integer, [Bool], ()] :-> [Integer, [Bool], ()]
    updateN2 = swap # dip cons

    updateN3 :: [Bool, Integer, (), [Bool]] :-> [Integer, (), [Bool]]
    updateN3 = dug @2 # dipN @2 cons

test_execute :: [TestTree]
test_execute =
  [ testCase "Two arguments lambda" $
      let lam :: [Integer, Integer] :-> [(), Integer]
          lam = add # unit
          code = push 3 # push lam # execute # drop @()
      in code -$? 5 @?= Right 8

  , testCase "Zero arguments lambda" $
      let lam :: '[] :-> '[Integer]
          lam = push 5
          code = drop # push lam # execute
      in code -$? (0 :: Natural) @?= Right 5
  ]

test_applicate :: [TestTree]
test_applicate =
  [ testCase "Simple partial application" $
      let lam :: '[Integer, Integer] :-> '[Integer]
          lam = add
          code = dip (push lam) # applicate # push 1 # exec
      in code -$? 5 @?= Right 6
  ]