test[Type]: Sampling is always conforming

src/Language/Json/Type.hs

@@ -29,6 +29,7 @@ import qualified Data.Text as Text
 import qualified Data.Array.Arbitrary as ArbitraryArray
 import qualified Data.Traversable as Traversable
 import qualified Test.QuickCheck.Gen as Gen
+import qualified Data.Map as Map
 
 data Type
   = Null
@@ -73,6 +74,19 @@ instance Monoid Type where
   mempty :: Type
   mempty = All
 
+instance Arbitrary Type where
+  arbitrary :: Gen Type
+  arbitrary = Gen.oneof
+    [ pure Null
+    , pure All
+    , pure Number
+    , pure String
+    , pure Boolean
+    , Array <$> arbitrary
+    , Union <$> Gen.scale (`div` 2) arbitrary
+    , Object . Map.mapKeys (Text.pack . getUnicodeString) <$> Gen.scale (`div` 2) arbitrary
+    ]
+
 mergeUnionObjects :: Set Type -> Set Type
 mergeUnionObjects set = let
   (objects, rest) = Set.partition isObject set

test/Test/Language/Json/Type.hs

@@ -1,14 +1,31 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE DerivingVia #-}
 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 Test.QuickCheck (allProperties, Property, Arbitrary (arbitrary), Gen)
 import qualified Test.Tasty.QuickCheck as Tasty.QuickCheck
 import Test.Tasty (TestTree)
+import Language.Json.Type (Type)
 
 prop_inferredTypeConformsSourceValue :: Json.PrintableValue -> Bool
 prop_inferredTypeConformsSourceValue (Json.PrintableValue value) = null (Type.conforms (Type.infer value) value)
 
+newtype TypeWithSampledValue = TypeWithSampledValue (Type, Json.Value)
+  deriving stock Show
+
+instance Arbitrary TypeWithSampledValue where
+  arbitrary :: Gen TypeWithSampledValue
+  arbitrary = do
+    layout <- arbitrary
+    value <- Type.sample layout
+    pure . TypeWithSampledValue $ (layout, value)
+
+prop_sampledValueConformsToType :: TypeWithSampledValue -> Bool
+prop_sampledValueConformsToType (TypeWithSampledValue (layout, value)) = null (Type.conforms layout value)
+
+
 return [] -- make ghc 'commit' already defined values
 properties :: [(String, Property)]
 properties = $allProperties