Views.hs

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

-- | Tests on views-related primitives.
module Test.Views
  ( test_ViewsSets
  ) where

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

import Morley.Michelson.Typed

dummyViewCode :: Integer -> ViewCode arg st arg
dummyViewCode id' = CAR :# PUSH (VInt id') :# DROP

dummyView :: HasCallStack => Text -> Integer -> View 'TUnit 'TUnit 'TUnit
dummyView name id' = View
  { vName = unsafe $ mkViewName name
  , vArgument = starNotes
  , vReturn = starNotes
  , vCode = dummyViewCode id'
  }

dummySomeView :: HasCallStack => Text -> Integer -> SomeView 'TUnit
dummySomeView = SomeView ... dummyView

test_ViewsSets :: TestTree
test_ViewsSets = testGroup "Views sets"
  [ testGroup "Instant construction"
    [ testCase "Can create views set with constructor" $
        assertBool "Failed to construct" $
          mkViewsSet [dummySomeView "a" 1, dummySomeView "b" 2]
          & isRight

    , testCase "Duplicate views cause failure" $
        mkViewsSet [dummySomeView "a" 1, dummySomeView "b" 2, dummySomeView "a" 3]
          @?= Left (DuplicatedViewName (unsafe $ mkViewName "a"))

    ]

  , testGroup "Incremental construction"
    [ testCase "Can incrementally build views set" $
        assertBool "Failed to construct" $
          pure emptyViewsSet
            >>= addViewToSet (dummyView "a" 1)
            >>= addViewToSet (dummyView "b" 2)
          & isRight

    , testCase "Duplicate views cause failure" $
        ( pure emptyViewsSet
          >>= addViewToSet (dummyView "a" 1)
          >>= addViewToSet (dummyView "b" 2)
          >>= addViewToSet (dummyView "a" 3)
        ) @?= Left (DuplicatedViewName (unsafe $ mkViewName "a"))

    ]

  , testGroup "Lookup"
    let viewsSet1 = unsafe $ mkViewsSet
          [ dummySomeView "" 0
          , dummySomeView "a" 1
          ]
    in
    [ testCase "Can find a present view" $ do
        lookupView (unsafe $ mkViewName "") viewsSet1
          @?= Just (dummySomeView "" 0)
        lookupView (unsafe $ mkViewName "a") viewsSet1
          @?= Just (dummySomeView "a" 1)

    , testCase "Fail to find a non-existent view" $
        lookupView (unsafe $ mkViewName "x") viewsSet1
          @?= Nothing

    ]

  ]