haskell/zap-tests/tests/Module/Zap/Canonicalize.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}

module Module.Zap.Canonicalize
  ( canonicalizeTests,
  )
where

import Zap (Parsed, Raw (..), createPure, encode, msgToLBS)
import qualified Zap.Basics as B
import Zap.Canonicalize
import qualified Zap.Message as M
import qualified Zap.Untyped as U
import Control.Monad (unless)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Vector as V
import Instances ()
import Test.Hspec
import Test.QuickCheck (property)
import Test.QuickCheck.IO (propertyIO)
import Util (zapCanonicalize)

canonicalizeTests :: Spec
canonicalizeTests =
  describe "canonicalization tests" $ do
    it "agrees with reference implementation" $
      property $ \case
        B.Struct (V.toList -> []) (V.toList -> []) ->
          -- skip this; it fails due to a bug in the reference implementation:
          --
          -- https://github.com/zap/zap/issues/1084
          --
          -- TODO: when that issue is fixed, stop skipping this case.
          propertyIO $ pure ()
        struct ->
          propertyIO $ implsAgreeOn struct

implsAgreeOn :: Parsed B.AnyStruct -> IO ()
implsAgreeOn struct = do
  let Just ourMsg = ourImplCanonicalize struct
  refMsg <- refImplCanonicalize struct
  unless (ourMsg == refMsg) $
    error $
      concat
        [ "Our implementation disagrees with the reference implementation on " ++ show struct,
          ".\n\nWe produce:\n\n",
          show $ LBS.unpack $ msgToLBS ourMsg,
          "\n\n",
          "But the reference implementation generates:\n\n",
          show $ LBS.unpack $ msgToLBS refMsg
        ]

ourImplCanonicalize :: Parsed B.AnyStruct -> Maybe (M.Message 'M.Const)
ourImplCanonicalize struct = createPure maxBound $ do
  msg <- M.newMessage Nothing
  Raw rawStruct <- encode msg struct
  (msg, _) <- canonicalizeMut rawStruct
  pure msg

refImplCanonicalize :: Parsed B.AnyStruct -> IO (M.Message 'M.Const)
refImplCanonicalize struct = do
  msg <- createPure maxBound $ do
    msg <- M.newMessage Nothing
    Raw rawStruct <- encode msg struct
    U.setRoot rawStruct
    pure msg
  lbs <- zapCanonicalize (msgToLBS msg)
  let segment = M.fromByteString $ LBS.toStrict lbs
  pure $ M.singleSegment segment