moonlight-triangulation-0.1.0.0: fuzz/decode/Main.hs

{-# LANGUAGE DataKinds #-}

module Main (main) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.List.NonEmpty (NonEmpty (..))
import Moonlight.Triangulation
import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget)
import Moonlight.Triangulation.Serialization
import Moonlight.Triangulation.Types (KnownConstraintMode)

data DecodeFuzzFailure
  = DecodeInvariantFailure !(NonEmpty InvariantViolation)
  | DecodeRoundTripFailure
  deriving stock (Show)

main :: IO ()
main = runFuzzTarget fuzzDecodeTriangulation

fuzzDecodeTriangulation :: BS.ByteString -> Either DecodeFuzzFailure ()
fuzzDecodeTriangulation bytes =
  checkUnconstrained (decodeTriangulation lazyBytes)
    *> checkConstrained (decodeTriangulation lazyBytes)
 where
  lazyBytes = BL.fromStrict bytes

checkUnconstrained
  :: Either SerializationError (Triangulation 'Unconstrained () () () ())
  -> Either DecodeFuzzFailure ()
checkUnconstrained = either (const (Right ())) checkDecoded

checkConstrained
  :: Either SerializationError (Triangulation 'Constrained () () () ())
  -> Either DecodeFuzzFailure ()
checkConstrained = either (const (Right ())) checkDecoded

checkDecoded
  :: KnownConstraintMode mode
  => Triangulation mode () () () ()
  -> Either DecodeFuzzFailure ()
checkDecoded triangulation =
  case validateTriangulation triangulation of
    violation : violations -> Left (DecodeInvariantFailure (violation :| violations))
    [] ->
      case decodeTriangulation (encodeTriangulation triangulation) of
        Right decoded
          | decoded == triangulation -> Right ()
        _ -> Left DecodeRoundTripFailure