diff --git a/src/Language/Json/Type.hs b/src/Language/Json/Type.hs index 6120d43..2df689a 100644 --- a/src/Language/Json/Type.hs +++ b/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