Main.hs

-- @generated by keiro-dsl 0.19.0.1 (language keiro-dsl 4) from conformance package workspace workspace-proof; do not edit.
module Main (main) where

import Control.Monad (when)
import Data.List (group, groupBy, sort, sortOn)
import Proof.WorkspaceProof.Generated.Conformance (runServiceConformanceChecks, serviceConformanceFacts)
import KeiroConformance.Expectations (expectedServiceConformanceFacts)
import System.Exit (exitFailure)

data FactResult
  = FactMatch String String
  | FactMismatch String String String
  | FactMissing String String
  | FactUnexpected String String

newtype UniqueFactMap = UniqueFactMap [(String, String)]

main :: IO ()
main = do
  checks <- runServiceConformanceChecks
  mapM_ renderCheck checks
  case compareFacts expectedServiceConformanceFacts serviceConformanceFacts of
    Left duplicates -> do
      mapM_ (putStrLn . ("FAIL  duplicate conformance fact key: " <>)) duplicates
      exitFailure
    Right facts -> do
      mapM_ renderFact facts
      when (any (not . snd) checks || any factFailed facts) exitFailure

renderCheck :: (String, Bool) -> IO ()
renderCheck (key, passed) = putStrLn ((if passed then "PASS  " else "FAIL  ") <> key)

renderFact :: FactResult -> IO ()
renderFact result = putStrLn (case result of
  FactMatch key _ -> "PASS  " <> key
  FactMismatch key expected actual -> "FAIL  " <> key <> " expected=" <> show expected <> " actual=" <> show actual
  FactMissing key expected -> "FAIL  " <> key <> " expected=" <> show expected <> " actual=<missing>"
  FactUnexpected key actual -> "FAIL  " <> key <> " expected=<missing> actual=" <> show actual)

factFailed :: FactResult -> Bool
factFailed FactMatch {} = False
factFailed _ = True

compareFacts :: [(String, String)] -> [(String, String)] -> Either [String] [FactResult]
compareFacts expected actual = do
  expectedMap <- uniqueFactMap "expected" expected
  actualMap <- uniqueFactMap "actual" actual
  pure [compareKey key expectedMap actualMap | key <- factKeys expectedMap actualMap]

uniqueFactMap :: String -> [(String, String)] -> Either [String] UniqueFactMap
uniqueFactMap side facts =
  case [side <> "/" <> fst first | entries@(first : _) <- groupBy sameKey (sortOn fst facts), length entries > 1] of
    [] -> Right (UniqueFactMap (sortOn fst facts))
    duplicates -> Left duplicates
  where
    sameKey left right = fst left == fst right

factKeys :: UniqueFactMap -> UniqueFactMap -> [String]
factKeys (UniqueFactMap expected) (UniqueFactMap actual) = [key | key : _ <- group (sort (map fst expected <> map fst actual))]

compareKey :: String -> UniqueFactMap -> UniqueFactMap -> FactResult
compareKey key (UniqueFactMap expected) (UniqueFactMap actual) =
  case (lookup key expected, lookup key actual) of
    (Just expectedValue, Just actualValue)
      | expectedValue == actualValue -> FactMatch key actualValue
      | otherwise -> FactMismatch key expectedValue actualValue
    (Just expectedValue, Nothing) -> FactMissing key expectedValue
    (Nothing, Just actualValue) -> FactUnexpected key actualValue
    (Nothing, Nothing) -> error "factKeys returned a key absent from both validated maps"