Lookup.hs

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

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Tests for Indigo Lookup

module Test.Lookup
  ( test_VarActions
  ) where

import Data.Singletons (Sing)
import Data.Typeable (eqT, (:~:)(..))
import Test.HUnit (Assertion, (@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Indigo hiding (fromInteger)
import Indigo.Backend.Lookup
import Indigo.Backend.Prelude (fromInteger)
import Lorentz.Instr qualified as L
import Lorentz.Macro qualified as L
import Morley.Util.Peano

--------------------------------------------------------------------------------

type FourInts = '[Integer, Integer, Integer, Integer]

fullStk :: StackVars' FourInts
fullStk = Ref 3 :& Ref 2 :& Ref 1 :& Ref 0 :& RNil

nthVar :: Sing (n :: Peano) -> RefId
nthVar n = case rdrop n fullStk of
  (Ref refId :: StkEl a) :& _ -> case eqT @a @Integer of
    Just Refl -> refId
    Nothing -> error "impossible: all Vars are for Integers"
  _ -> error "this is not supposed to happen"

--------------------------------------------------------------------------------

-- | Tests that VarActions match their Lorentz counterpart at different depths.
test_VarActions :: [TestTree]
test_VarActions =
  [ testAtDepth1
  , testAtDepth2
  , testAtDepth3
  , testAtDepth4
  ]

testAtDepth1 :: TestTree
testAtDepth1 = testGroup "varActions match Lorentz at depth 1"
  [ testCase "get"    $ testVarActionGet    sn
  , testCase "set"    $ testVarActionSet    sn
  , testCase "update" $ testVarActionUpdate sn
  ]
  where
    sn = SS SZ

testAtDepth2 :: TestTree
testAtDepth2 = testGroup "varActions match Lorentz at depth 2"
  [ testCase "get"    $ testVarActionGet    sn
  , testCase "set"    $ testVarActionSet    sn
  , testCase "update" $ testVarActionUpdate sn
  ]
  where
    sn = SS $ SS SZ

testAtDepth3 :: TestTree
testAtDepth3 = testGroup "varActions match Lorentz at depth 3"
  [ testCase "get"    $ testVarActionGet    sn
  , testCase "set"    $ testVarActionSet    sn
  , testCase "update" $ testVarActionUpdate sn
  ]
  where
    sn = SS . SS $ SS SZ

testAtDepth4 :: TestTree
testAtDepth4 = testGroup "varActions match Lorentz at depth 4"
  [ testCase "get"    $ testVarActionGet    sn
  , testCase "set"    $ testVarActionSet    sn
  , testCase "update" $ testVarActionUpdate sn
  ]
  where
    sn = SS . SS . SS $ SS SZ

--------------------------------------------------------------------------------

testVarActionGet
  :: forall (n :: Peano) out. L.ConstraintDUPNLorentz ('S n) FourInts out Integer
  => Sing ('S n) -> Assertion
testVarActionGet (SS n) = duupXInstr @?= varActionGet (nthVar n) (StkElements fullStk)
  where
    duupXInstr :: FourInts :-> (Integer ': FourInts)
    duupXInstr = L.dupNPeano @('S n) @Integer @FourInts @out

testVarActionSet
  :: forall (n :: Peano) mid tail.
     ( L.ConstraintReplaceNLorentz n FourInts Integer mid tail
     , L.ReplaceN ('S n) FourInts Integer mid tail
     )
  => Sing ('S n) -> Assertion
testVarActionSet (SS n) = replaceNInstr @?= varActionSet (nthVar n) (StkElements fullStk)
  where
    replaceNInstr :: (Integer ': FourInts) :-> FourInts
    replaceNInstr = L.replaceNImpl @('S n) @FourInts @Integer @mid @tail

testVarActionUpdate
  :: forall (n :: Peano) mid tail.
     ( L.ConstraintUpdateNLorentz n FourInts Integer Integer mid tail
     , L.UpdateN ('S n) FourInts Integer Integer mid tail
     )
  => Sing ('S n) -> Assertion
testVarActionUpdate (SS n) = updateNInstr @?= varActionUpdate @Integer (nthVar n) (StkElements fullStk) L.add
  where
    updateNInstr :: (Integer ': FourInts) :-> FourInts
    updateNInstr = L.updateNImpl @('S n) @FourInts @Integer @Integer @mid @tail L.add