feat[Type]: sampling, COMPLETE pragma

src/Language/Json/Type.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
-module Language.Json.Type (infer, Type(..), isObject, conforms, Mismatch(..)) where
+module Language.Json.Type (infer, Type(..), isObject, conforms, Mismatch(..), sample) where
 import Data.Map.Strict (Map)
 import Data.Text (Text)
 import Data.Set (Set)
@@ -24,6 +24,11 @@ import qualified Data.Array.IArray as Array
 import qualified Data.List as List
 import Control.Arrow ((>>>))
 import GHC.Records (HasField (getField))
+import Test.QuickCheck (Gen, Arbitrary (arbitrary), UnicodeString (getUnicodeString))
+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
 
 data Type
   = Null
@@ -45,6 +50,8 @@ pattern Union set <- Union' set where
       [t] -> t
       _   -> Union' merged
 
+{-# COMPLETE Null, All, Number, String, Boolean, Array, Union, Object :: Type #-}
+
 instance Semigroup Type where
   (<>) :: Type -> Type -> Type
   (<>) a b = if a == b
@@ -128,3 +135,13 @@ conforms' path layout value = case (value, layout) of
       else Foldable.concatMap id mismatches
   _ -> pure $ Mismatch {expected=layout, inferred=infer value, value=value, path=path}
 
+sample :: Type -> Gen Value
+sample = \case
+  All                   -> arbitrary
+  Null                  -> pure Value.Null
+  Number                -> Value.Number <$> arbitrary
+  String                -> Value.String . Text.pack . getUnicodeString <$> arbitrary
+  Boolean               -> Value.Boolean <$> arbitrary
+  Array elementType     -> Value.Array . ArbitraryArray.get <$> ArbitraryArray.liftArbitrary (sample elementType)
+  Object fields         -> Value.Object <$> Traversable.mapM sample fields
+  Union types           -> Gen.oneof $ sample <$> Set.toList types