test: Testing caught me doing stupid stuff

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

package.yaml

@@ -24,6 +24,10 @@ dependencies:
 - containers
 - text
 - pretty-parse
+- quickcheck-instances
+- QuickCheck
+- tasty
+- tasty-quickcheck
 
 ghc-options:
 - -Wall

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"

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)

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}
 

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
+  ]

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