From c78d261a1b74ebe44112228819bd9e9435d8b13f Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 22 Aug 2025 10:04:23 +0200 Subject: [PATCH] test: Testing caught me doing stupid stuff --- hon.cabal | 19 +++++++++++++++--- package.yaml | 4 ++++ src/Language/Json.hs | 35 +++++++++++++++++++++++++++++++-- src/Language/Json/Path.hs | 2 ++ src/Language/Json/Type.hs | 6 ++++++ test/Spec.hs | 10 +++++++++- test/Test/Language/Json/Type.hs | 17 ++++++++++++++++ 7 files changed, 87 insertions(+), 6 deletions(-) create mode 100644 test/Test/Language/Json/Type.hs diff --git a/hon.cabal b/hon.cabal index d226fde..2b54b4f 100644 --- a/hon.cabal +++ b/hon.cabal @@ -29,10 +29,14 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - array + QuickCheck + , array , base >=4.7 && <5 , containers , pretty-parse + , quickcheck-instances + , tasty + , tasty-quickcheck , text default-language: Haskell2010 @@ -44,11 +48,15 @@ executable hon-exe app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - array + QuickCheck + , array , base >=4.7 && <5 , containers , hon , pretty-parse + , quickcheck-instances + , tasty + , tasty-quickcheck , text default-language: Haskell2010 @@ -56,15 +64,20 @@ test-suite hon-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Test.Language.Json.Type Paths_hon hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - array + QuickCheck + , array , base >=4.7 && <5 , containers , hon , pretty-parse + , quickcheck-instances + , tasty + , tasty-quickcheck , text default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index f3804df..4e07f0f 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,10 @@ dependencies: - containers - text - pretty-parse +- quickcheck-instances +- QuickCheck +- tasty +- tasty-quickcheck ghc-options: - -Wall diff --git a/src/Language/Json.hs b/src/Language/Json.hs index a2d8d03..d9f7f95 100644 --- a/src/Language/Json.hs +++ b/src/Language/Json.hs @@ -3,7 +3,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DeriveGeneric #-} -module Language.Json (Value(..), null, true, false, boolean, buildInteger, number, document) where +{-# LANGUAGE InstanceSigs #-} +module Language.Json (Value(..), null, true, false, boolean, buildInteger, number, document, PrintableValue(..)) where import Data.Text (Text) import Data.Array.IArray (Array) import Numeric.Natural (Natural) @@ -25,6 +26,10 @@ import qualified Data.Array.IArray as Array import qualified Data.Map.Strict as Map import GHC.Generics ( Generic, Generically(..) ) import Pretty.Serialize (PrettySerialize) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, UnicodeString (getUnicodeString), PrintableString (getPrintableString)) +import qualified Test.QuickCheck.Gen as Gen +import Test.QuickCheck.Instances.Array () +import Test.QuickCheck.Instances.Natural () data Value @@ -34,9 +39,35 @@ data Value | Number Rational | Array (Array Natural Value) | Object (Map Text Value) - deriving (Show, Generic) + deriving (Show, Generic, Eq, Ord) deriving PrettySerialize via Generically Value +-- generaty arbitrary values, for testing +instance Arbitrary Value where + arbitrary :: Gen Value + arbitrary = Gen.oneof + [ pure Null + , String . Text.pack . getUnicodeString <$> arbitrary + , Boolean <$> arbitrary + , Number <$> arbitrary + , Array <$> Gen.scale (`div` 2) arbitrary + , Object . Map.mapKeys (Text.pack . getUnicodeString) <$> Gen.scale (`div` 2) arbitrary + ] + +newtype PrintableValue = PrintableValue Value + deriving stock Show + +instance Arbitrary PrintableValue where + arbitrary :: Gen PrintableValue + arbitrary = PrintableValue <$> Gen.oneof + [ pure Null + , String . Text.pack . getPrintableString <$> arbitrary + , Boolean <$> arbitrary + , Number <$> arbitrary + , Array <$> Gen.scale (`div` 2) arbitrary + , Object . Map.mapKeys (Text.pack . getPrintableString) <$> Gen.scale (`div` 2) arbitrary + ] + null :: Parser Value null = do Parser.exact "null" diff --git a/src/Language/Json/Path.hs b/src/Language/Json/Path.hs index 5817379..12c8a0d 100644 --- a/src/Language/Json/Path.hs +++ b/src/Language/Json/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingStrategies #-} module Language.Json.Path (Path(..)) where import Numeric.Natural (Natural) import Data.Text (Text) @@ -5,3 +6,4 @@ import Data.Text (Text) data Path = AtIndex Natural | InField Text + deriving stock (Show, Eq, Ord) diff --git a/src/Language/Json/Type.hs b/src/Language/Json/Type.hs index eb142ec..6120d43 100644 --- a/src/Language/Json/Type.hs +++ b/src/Language/Json/Type.hs @@ -94,6 +94,7 @@ data Mismatch = Mismatch , value :: Value , path :: [Path] } + deriving stock (Show, Eq, Ord) instance HasField "actual" Mismatch Type where getField :: Mismatch -> Type @@ -120,5 +121,10 @@ conforms' path layout value = case (value, layout) of fieldMissing = Map.Merge.mapMissing $ \ key fieldType -> conforms' (InField key:path) fieldType Value.Null mismatches = Map.Merge.merge fieldMissing typeMissing bothPresent fieldTypes fields in Foldable.concatMap id mismatches + (_, Union types) -> let -- does it match any of the union types? + mismatches = flip conforms value `Set.map` types + in if Foldable.any List.null mismatches + then mempty + else Foldable.concatMap id mismatches _ -> pure $ Mismatch {expected=layout, inferred=infer value, value=value, path=path} diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..283a9c8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,10 @@ + +-- test framework +import Test.Tasty (defaultMain) +import qualified Test.Tasty as Tasty +import qualified Test.Language.Json.Type + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = defaultMain $ Tasty.testGroup "all" + [ Test.Language.Json.Type.testGroup + ] diff --git a/test/Test/Language/Json/Type.hs b/test/Test/Language/Json/Type.hs new file mode 100644 index 0000000..a8dc3d4 --- /dev/null +++ b/test/Test/Language/Json/Type.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} +module Test.Language.Json.Type (testGroup) where +import qualified Language.Json.Type as Type +import qualified Language.Json as Json +import Test.QuickCheck (allProperties, Property) +import qualified Test.Tasty.QuickCheck as Tasty.QuickCheck +import Test.Tasty (TestTree) + +prop_inferredTypeConformsSourceValue :: Json.PrintableValue -> Bool +prop_inferredTypeConformsSourceValue (Json.PrintableValue value) = null (Type.conforms (Type.infer value) value) + +return [] -- make ghc 'commit' already defined values +properties :: [(String, Property)] +properties = $allProperties + +testGroup :: TestTree +testGroup = Tasty.QuickCheck.testProperties "Language.Json.Type" properties