JsonCompare

Main.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Applicative (liftA2)
import Data.Aeson (Options (..), defaultOptions, eitherDecode')
import Data.Aeson.TH (deriveJSON)
import Data.ByteString.Internal qualified as BS
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as BS
import Data.Char (toLower)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import System.Exit qualified as Exit

newtype TestDeep = MkTestDeep {deep :: Text}
  deriving (Eq, Show)

newtype TestNote = MkTestNote {note :: TestDeep}
  deriving (Eq, Show)

data TestData = MkTestData
  { text :: Maybe Text,
    num :: Maybe Int,
    float :: Maybe Float,
    list :: Maybe [Text],
    sub :: Maybe TestNote
  }
  deriving (Eq, Show)

data TestLoc = MkTestLoc
  { loc_col :: Int,
    loc_fn :: Text,
    loc_ln :: Int,
    loc_mod :: Text,
    loc_pkg :: Text
  }
  deriving (Eq, Show)

data TestOutput = MkTestOutput
  { testAt :: Text,
    testEnv :: Text,
    testNs :: [Text],
    testData :: TestData,
    testApp :: [Text],
    testMsg :: Text,
    testPid :: Text,
    testLoc :: Maybe TestLoc,
    testHost :: Text,
    testSev :: Text,
    testThread :: Text
  }
  deriving (Eq, Show)

$(deriveJSON defaultOptions ''TestDeep)
$(deriveJSON defaultOptions ''TestNote)
$(deriveJSON defaultOptions ''TestData)
$(deriveJSON defaultOptions ''TestLoc)
$(deriveJSON defaultOptions {fieldLabelModifier = fmap toLower . drop 4} ''TestOutput)

main :: IO ()
main = do
  aeson1Lines <- T.lines . T.pack <$> readFile "Handle-json.golden"
  aeson2Lines <- T.lines . T.pack <$> readFile "Handle-json-aeson2.golden"
  compareLines 0 aeson1Lines aeson2Lines

compareLines :: Int -> [Text] -> [Text] -> IO ()
compareLines !idx [] [] = putStrLn $ "Equal after lines: " <> show idx
compareLines !idx xs@(_ : _) [] = Exit.die $ "LHS had extra lines: " <> show (length xs)
compareLines !idx [] ys@(_ : _) = Exit.die $ "RHS had extra lines: " <> show (length ys)
compareLines !idx (x : xs) (y : ys) = do
  let x' :: Either String TestOutput
      x' = eitherDecode' $ t2b x
      y' = eitherDecode' $ t2b y
  case liftA2 (==) x' y' of
    Right True -> compareLines (idx + 1) xs ys
    Right False -> do
      print x'
      print y'
      Exit.die $ "Not equal on line " <> show idx
    other -> do
      print x
      print y
      Exit.die $ "Error on line " <> show idx <> ": " <> show other
  where
    t2b :: Text -> ByteString
    t2b = BS.fromStrict . T.encodeUtf8