fb-util-0.1.0.1: tests/DynamicTest.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

module DynamicTest (main) where

import Control.Exception (bracket)
import Data.Aeson hiding (parseJSON)
import qualified Data.ByteString.Lazy as LB
import Data.Either
import Data.Text (Text)
import Foreign
import System.Timeout (timeout)
import Test.HUnit
import TestRunner

import Foreign.CPP.Marshallable
import Foreign.CPP.Dynamic
import Foreign.CPP.HsStruct

expectedJSON :: Value
expectedJSON = object
  [ "int"    .= (42::Int)
  , "string" .= ("wibble" :: Text)
  , "double" .= (1000.0 / 1024.0 :: Double)
  , "array"  .= [(1::Int)..3]
  , "object" .= object ["a" .= ("b" :: Text)]
  , "null"   .= Null
  , "bool"   .= True
  ]

readDynamicTest :: Test
readDynamicTest = TestCase $ do
  json <- bracket newDynamic delete readDynamic
  assertEqual "readDynamicTest" expectedJSON json

peekHsJSONTest :: Test
peekHsJSONTest = TestCase $ do
  json <- bracket newHsJSON delete $ fmap hsJSON . peek
  assertEqual "peekHsJSONTest" expectedJSON json

withDynamicTest :: Test
withDynamicTest = TestCase $ do
  json <- withDynamic expectedJSON readDynamic
  assertEqual "withDynamicTest" expectedJSON json

nestedValueTest :: Test
nestedValueTest = TestCase $ do
  -- readDynamic should finish in linear time
  Just json <- timeout 1000000 $ withDynamic nestedJSON readDynamic
  assertEqual "nestedValueTest" nestedJSON json
  where
  nestedJSON = foldr ($!) (toJSON True) $
    take 5000 $ cycle [toArray, toObject]
  toArray v = toJSON [v]
  toObject v = object ["key" .= v]

parseJSONTest :: Test
parseJSONTest = TestCase $ do
  result <- parseJSON (LB.toStrict (encode expectedJSON))
  assertBool "parseJSON" $
    case result of
      Left _ -> False
      Right val -> val == expectedJSON

parseJSONError :: Test
parseJSONError = TestCase $ do
  result <- parseJSON "this is not JSON"
  print result
  assertBool "parseJSON" $ isLeft result

main :: IO ()
main = testRunner $ TestList $ map (uncurry TestLabel)
  [ ("readDynamicTest", readDynamicTest)
  , ("peekHsJSONTest", peekHsJSONTest)
  , ("withDynamicTest", withDynamicTest)
  , ("nestedValueTest", nestedValueTest)
  , ("parseJSONTest", parseJSONTest)
  , ("parseJSONError", parseJSONError)
  ]

foreign import ccall unsafe "newDynamic"
  newDynamic :: IO (Ptr Dynamic)

foreign import ccall unsafe "newHsJSON"
  newHsJSON :: IO (Ptr HsJSON)